diff options
Diffstat (limited to 'ghc/compiler/main')
| -rw-r--r-- | ghc/compiler/main/BinIface.hs | 1051 | ||||
| -rw-r--r-- | ghc/compiler/main/CmdLineOpts.lhs | 1 | ||||
| -rw-r--r-- | ghc/compiler/main/DriverFlags.hs | 3 | ||||
| -rw-r--r-- | ghc/compiler/main/DriverPipeline.hs | 46 | ||||
| -rw-r--r-- | ghc/compiler/main/HscMain.lhs | 293 | ||||
| -rw-r--r-- | ghc/compiler/main/HscStats.lhs | 35 | ||||
| -rw-r--r-- | ghc/compiler/main/HscTypes.lhs | 769 | ||||
| -rw-r--r-- | ghc/compiler/main/Main.hs | 8 | ||||
| -rw-r--r-- | ghc/compiler/main/MkIface.lhs | 870 | ||||
| -rw-r--r-- | ghc/compiler/main/ParsePkgConf.y | 4 | ||||
| -rw-r--r-- | ghc/compiler/main/TidyPgm.lhs | 277 |
11 files changed, 650 insertions, 2707 deletions
diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs deleted file mode 100644 index c507f2e4dc..0000000000 --- a/ghc/compiler/main/BinIface.hs +++ /dev/null @@ -1,1051 +0,0 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} --- --- (c) The University of Glasgow 2002 --- --- Binary interface file support. - -module BinIface ( writeBinIface, readBinIface, v_IgnoreHiVersion ) where - -#include "HsVersions.h" - -import HscTypes -import BasicTypes -import NewDemand -import HsTypes -import HsCore -import HsDecls -import HsBinds -import HsPat ( HsConDetails(..) ) -import TyCon -import Class -import VarEnv -import CostCentre -import RdrName ( mkRdrUnqual, mkRdrQual ) -import Name ( Name, nameOccName, nameModule_maybe ) -import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts ) -import Module ( moduleName ) -import OccName ( OccName ) -import RnHsSyn -import DriverState ( v_Build_tag ) -import CmdLineOpts ( opt_HiVersion ) -import Panic -import SrcLoc -import Binary -import Util - -import DATA_IOREF -import EXCEPTION ( throwDyn ) -import Monad ( when ) - -#include "HsVersions.h" - --- --------------------------------------------------------------------------- --- We write out a ModIface, but read it in as a ParsedIface. --- There are some big differences, and some subtle ones. We do most --- of the conversion on the way out, so there is minimal fuss when we --- read it back in again (see RnMonad.lhs) - --- The main difference is that all Names in a ModIface are RdrNames in --- a ParsedIface, so when writing out a Name in binary we make sure it --- is binary-compatible with a RdrName. - --- Other subtle differences: --- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put --- Modules as ModuleNames. --- - pi_exports and pi_usages, Names have --- to be converted to OccNames. --- - pi_fixity is a NameEnv in ModIface, --- but a list of (Name,Fixity) pairs in ParsedIface. --- - versioning is totally different. --- - deprecations are different. - -writeBinIface :: FilePath -> ModIface -> IO () -writeBinIface hi_path mod_iface - = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface - -readBinIface :: FilePath -> IO ParsedIface -readBinIface hi_path = getBinFileWithDict hi_path - - --- %********************************************************* --- %* * --- All the Binary instances --- %* * --- %********************************************************* - --- BasicTypes -{-! for IPName derive: Binary !-} -{-! for Fixity derive: Binary !-} -{-! for FixityDirection derive: Binary !-} -{-! for NewOrData derive: Binary !-} -{-! for Boxity derive: Binary !-} -{-! for StrictnessMark derive: Binary !-} -{-! for Activation derive: Binary !-} - -instance Binary Name where - -- we must print these as RdrNames, because that's how they will be read in - put_ bh name - = case nameModule_maybe name of - Just mod - | this_mod == mod -> put_ bh (mkRdrUnqual occ) - | otherwise -> put_ bh (mkRdrQual (moduleName mod) occ) - _ -> put_ bh (mkRdrUnqual occ) - where - occ = nameOccName name - (this_mod,_,_,_) = getUserData bh - - get bh = error "can't Binary.get a Name" - --- NewDemand -{-! for Demand derive: Binary !-} -{-! for Demands derive: Binary !-} -{-! for DmdResult derive: Binary !-} -{-! for StrictSig derive: Binary !-} - -instance Binary DmdType where - -- ignore DmdEnv when spitting out the DmdType - put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p) - get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr) - --- TyCon -{-! for DataConDetails derive: Binary !-} - --- Class -{-! for DefMeth derive: Binary !-} - --- HsTypes -{-! for HsPred derive: Binary !-} -{-! for HsType derive: Binary !-} -{-! for HsTupCon derive: Binary !-} -{-! for HsTyVarBndr derive: Binary !-} - --- HsCore -{-! for UfExpr derive: Binary !-} -{-! for UfConAlt derive: Binary !-} -{-! for UfBinding derive: Binary !-} -{-! for UfBinder derive: Binary !-} -{-! for HsIdInfo derive: Binary !-} -{-! for UfNote derive: Binary !-} - --- HsDecls -{-! for ConDetails derive: Binary !-} -{-! for BangType derive: Binary !-} - -instance (Binary name) => Binary (TyClDecl name) where - put_ bh (IfaceSig name ty idinfo _) = do - putByte bh 0 - put_ bh name - lazyPut bh ty - lazyPut bh idinfo - put_ bh (ForeignType ae af ag ah) = - error "Binary.put_(TyClDecl): ForeignType" - put_ bh (TyData ai aj ak al am _ (Just generics) _) = do - putByte bh 2 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh al - put_ bh am - -- ignore Derivs - put_ bh generics -- Record whether generics needed or not - put_ bh (TySynonym aq ar as _) = do - putByte bh 3 - put_ bh aq - put_ bh ar - put_ bh as - put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do - putByte bh 4 - put_ bh ctxt - put_ bh nm - put_ bh tyvars - put_ bh fds - put_ bh sigs - -- ignore methods (there should be none) - -- ignore SrcLoc - get bh = do - h <- getByte bh - case h of - 0 -> do - name <- get bh - ty <- lazyGet bh - idinfo <- lazyGet bh - return (IfaceSig name ty idinfo noSrcLoc) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do - n_or_d <- get bh - ctx <- get bh - nm <- get bh - tyvars <- get bh - cons <- get bh - generics <- get bh - return (TyData n_or_d ctx nm tyvars cons - Nothing (Just generics) noSrcLoc) - 3 -> do - aq <- get bh - ar <- get bh - as <- get bh - return (TySynonym aq ar as noSrcLoc) - _ -> do - ctxt <- get bh - nm <- get bh - tyvars <- get bh - fds <- get bh - sigs <- get bh - return (ClassDecl ctxt nm tyvars fds sigs - Nothing noSrcLoc) - -instance (Binary name) => Binary (ConDecl name) where - put_ bh (ConDecl aa ac ad ae _) = do - put_ bh aa - put_ bh ac - put_ bh ad - put_ bh ae - -- ignore SrcLoc - get bh = do - aa <- get bh - ac <- get bh - ad <- get bh - ae <- get bh - return (ConDecl aa ac ad ae noSrcLoc) - -instance (Binary name) => Binary (InstDecl name) where - put_ bh (InstDecl aa _ _ ad _) = do - put_ bh aa - -- ignore MonoBinds - -- ignore Sigs - put_ bh ad - -- ignore SrcLoc - get bh = do - aa <- get bh - ad <- get bh - return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc) - -instance (Binary name) => Binary (RuleDecl name) where - put_ bh (IfaceRule ag ah ai aj ak al _) = do - put_ bh ag - put_ bh ah - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh al - -- ignore SrcLoc - get bh = do ag <- get bh - ah <- get bh - ai <- get bh - aj <- get bh - ak <- get bh - al <- get bh - return (IfaceRule ag ah ai aj ak al noSrcLoc) - -instance (Binary name) => Binary (DeprecDecl name) where - put_ bh (Deprecation aa ab _) = do - put_ bh aa - put_ bh ab - -- ignore SrcLoc - get bh = do - aa <- get bh - ab <- get bh - return (Deprecation aa ab noSrcLoc) - --- HsBinds -instance Binary name => Binary (Sig name) where - put_ bh (ClassOpSig n def ty _) = do put_ bh n; put_ bh def; put_ bh ty - get bh = do - n <- get bh - def <- get bh - ty <- get bh - return (ClassOpSig n def ty noSrcLoc) - --- CostCentre -{-! for IsCafCC derive: Binary !-} -{-! for IsDupdCC derive: Binary !-} -{-! for CostCentre derive: Binary !-} - - - -instance Binary ModIface where - put_ bh iface = do - build_tag <- readIORef v_Build_tag - put_ bh (show opt_HiVersion ++ build_tag) - p <- put_ bh (moduleName (mi_module iface)) - put_ bh (mi_package iface) - put_ bh (vers_module (mi_version iface)) - put_ bh (mi_orphan iface) - -- no: mi_boot - lazyPut bh (mi_deps iface) - lazyPut bh (map usageToOccName (mi_usages iface)) - put_ bh (vers_exports (mi_version iface), - map exportItemToRdrExportItem (mi_exports iface)) - put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface)) - (vers_decls (mi_version iface))) - -- no: mi_globals - put_ bh (collectFixities (mi_fixities iface) - (dcl_tycl (mi_decls iface))) - put_ bh (dcl_insts (mi_decls iface)) - lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface)) - lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface)) - - -- Read in as a ParsedIface, not a ModIface. See above. - get bh = error "Binary.get: ModIface" - -declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version - -> [(Version, RenamedTyClDecl)] -declsToVersionedDecls decls env - = map add_vers decls - where add_vers d = - case lookupNameEnv env (tyClDeclName d) of - Nothing -> (initialVersion, d) - Just v -> (v, d) - - ---NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs -deprecsToIfaceDeprecs NoDeprecs = Nothing -deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt) -deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env)) - - -{-! for GenAvailInfo derive: Binary !-} -{-! for WhatsImported derive: Binary !-} - --- For binary interfaces we need to convert the ImportVersion Names to OccNames -usageToOccName :: Usage Name -> Usage OccName -usageToOccName usg - = usg { usg_entities = [ (nameOccName n, v) | (n,v) <- usg_entities usg ] } - -exportItemToRdrExportItem (mn, avails) - = (mn, map availInfoToRdrAvailInfo avails) - -availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo -availInfoToRdrAvailInfo (Avail n) - = Avail (nameOccName n) -availInfoToRdrAvailInfo (AvailTC n ns) - = AvailTC (nameOccName n) (map nameOccName ns) - --- --------------------------------------------------------------------------- --- Reading a binary interface into ParsedIface - -instance Binary ParsedIface where - put_ bh ParsedIface{ - pi_mod = module_name, - pi_pkg = pkg_name, - pi_vers = module_ver, - pi_orphan = orphan, - pi_usages = usages, - pi_exports = exports, - pi_decls = tycl_decls, - pi_fixity = fixities, - pi_insts = insts, - pi_rules = rules, - pi_deprecs = deprecs } = do - build_tag <- readIORef v_Build_tag - put_ bh (show opt_HiVersion ++ build_tag) - put_ bh module_name - put_ bh pkg_name - put_ bh module_ver - put_ bh orphan - lazyPut bh usages - put_ bh exports - put_ bh tycl_decls - put_ bh fixities - put_ bh insts - lazyPut bh rules - lazyPut bh deprecs - get bh = do - check_ver <- get bh - ignore_ver <- readIORef v_IgnoreHiVersion - build_tag <- readIORef v_Build_tag - let our_ver = show opt_HiVersion ++ build_tag - when (check_ver /= our_ver && not ignore_ver) $ - -- use userError because this will be caught by readIface - -- which will emit an error msg containing the iface module name. - throwDyn (ProgramError ( - "mismatched interface file versions: expected " - ++ our_ver ++ ", found " ++ check_ver)) - module_name <- get bh -- same rep. as Module, so that's ok - pkg_name <- get bh - module_ver <- get bh - orphan <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - tycl_decls <- {-# SCC "bin_tycldecls" #-} get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - insts <- {-# SCC "bin_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh - return (ParsedIface { - pi_mod = module_name, - pi_pkg = pkg_name, - pi_vers = module_ver, - pi_orphan = orphan, - pi_deps = deps, - pi_usages = usages, - pi_exports = exports, - pi_decls = tycl_decls, - pi_fixity = fixities, - pi_insts = reverse insts, - pi_rules = rules, - pi_deprecs = deprecs }) - -GLOBAL_VAR(v_IgnoreHiVersion, False, Bool) - --- ---------------------------------------------------------------------------- -{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} - --- Imported from other files :- - -instance Binary Dependencies where - put_ bh deps = do put_ bh (dep_mods deps) - put_ bh (dep_pkgs deps) - put_ bh (dep_orphs deps) - - get bh = do ms <- get bh - ps <- get bh - os <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os }) - -instance (Binary name) => Binary (GenAvailInfo name) where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - return (AvailTC ab ac) - -instance (Binary name) => Binary (Usage name) where - put_ bh usg = do - put_ bh (usg_name usg) - put_ bh (usg_mod usg) - put_ bh (usg_exports usg) - put_ bh (usg_entities usg) - put_ bh (usg_rules usg) - - get bh = do - nm <- get bh - mod <- get bh - exps <- get bh - ents <- get bh - rules <- get bh - return (Usage { usg_name = nm, usg_mod = mod, - usg_exports = exps, usg_entities = ents, - usg_rules = rules }) - -instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore aa) = do - putByte bh 2 - put_ bh aa - put_ bh (ActiveAfter ab) = do - putByte bh 3 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return NeverActive - 1 -> do return AlwaysActive - 2 -> do aa <- get bh - return (ActiveBefore aa) - _ -> do ab <- get bh - return (ActiveAfter ab) - -instance Binary StrictnessMark where - put_ bh MarkedUserStrict = do - putByte bh 0 - put_ bh MarkedStrict = do - putByte bh 1 - put_ bh MarkedUnboxed = do - putByte bh 2 - put_ bh NotMarkedStrict = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return MarkedUserStrict - 1 -> do return MarkedStrict - 2 -> do return MarkedUnboxed - _ -> do return NotMarkedStrict - -instance Binary Boxity where - put_ bh Boxed = do - putByte bh 0 - put_ bh Unboxed = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Boxed - _ -> do return Unboxed - -instance Binary NewOrData where - put_ bh NewType = do - putByte bh 0 - put_ bh DataType = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return NewType - _ -> do return DataType - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (Fixity aa ab) - -instance (Binary name) => Binary (FixitySig name) where - put_ bh (FixitySig aa ab _) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (FixitySig aa ab noSrcLoc) - -instance (Binary name) => Binary (IPName name) where - put_ bh (Dupable aa) = do - putByte bh 0 - put_ bh aa - put_ bh (Linear ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Dupable aa) - _ -> do ab <- get bh - return (Linear ab) - -instance Binary Demand where - put_ bh Top = do - putByte bh 0 - put_ bh Abs = do - putByte bh 1 - put_ bh (Call aa) = do - putByte bh 2 - put_ bh aa - put_ bh (Eval ab) = do - putByte bh 3 - put_ bh ab - put_ bh (Defer ac) = do - putByte bh 4 - put_ bh ac - put_ bh (Box ad) = do - putByte bh 5 - put_ bh ad - put_ bh Bot = do - putByte bh 6 - get bh = do - h <- getByte bh - case h of - 0 -> do return Top - 1 -> do return Abs - 2 -> do aa <- get bh - return (Call aa) - 3 -> do ab <- get bh - return (Eval ab) - 4 -> do ac <- get bh - return (Defer ac) - 5 -> do ad <- get bh - return (Box ad) - _ -> do return Bot - -instance Binary Demands where - put_ bh (Poly aa) = do - putByte bh 0 - put_ bh aa - put_ bh (Prod ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Poly aa) - _ -> do ab <- get bh - return (Prod ab) - -instance Binary DmdResult where - put_ bh TopRes = do - putByte bh 0 - put_ bh RetCPR = do - putByte bh 1 - put_ bh BotRes = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return TopRes - 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off - -- The wrapper was generated for CPR in - -- the imported module! - _ -> do return BotRes - -instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh - return (StrictSig aa) - -instance (Binary name) => Binary (HsTyVarBndr name) where - put_ bh (UserTyVar aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceTyVar ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UserTyVar aa) - _ -> do ab <- get bh - ac <- get bh - return (IfaceTyVar ab ac) - -instance Binary HsTupCon where - put_ bh (HsTupCon ab ac) = do - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - return (HsTupCon ab ac) - -instance (Binary name) => Binary (HsTyOp name) where - put_ bh HsArrow = putByte bh 0 - put_ bh (HsTyOp n) = do putByte bh 1 - put_ bh n - - get bh = do h <- getByte bh - case h of - 0 -> return HsArrow - 1 -> do a <- get bh - return (HsTyOp a) - -instance (Binary name) => Binary (HsType name) where - put_ bh (HsForAllTy aa ab ac) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh (HsTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (HsAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (HsFunTy ag ah) = do - putByte bh 3 - put_ bh ag - put_ bh ah - put_ bh (HsListTy ai) = do - putByte bh 4 - put_ bh ai - put_ bh (HsPArrTy aj) = do - putByte bh 5 - put_ bh aj - put_ bh (HsTupleTy ak al) = do - putByte bh 6 - put_ bh ak - put_ bh al - put_ bh (HsOpTy am an ao) = do - putByte bh 7 - put_ bh am - put_ bh an - put_ bh ao - put_ bh (HsNumTy ap) = do - putByte bh 8 - put_ bh ap - put_ bh (HsPredTy aq) = do - putByte bh 9 - put_ bh aq - put_ bh (HsKindSig ar as) = do - putByte bh 10 - put_ bh ar - put_ bh as - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - return (HsForAllTy aa ab ac) - 1 -> do ad <- get bh - return (HsTyVar ad) - 2 -> do ae <- get bh - af <- get bh - return (HsAppTy ae af) - 3 -> do ag <- get bh - ah <- get bh - return (HsFunTy ag ah) - 4 -> do ai <- get bh - return (HsListTy ai) - 5 -> do aj <- get bh - return (HsPArrTy aj) - 6 -> do ak <- get bh - al <- get bh - return (HsTupleTy ak al) - 7 -> do am <- get bh - an <- get bh - ao <- get bh - return (HsOpTy am an ao) - 8 -> do ap <- get bh - return (HsNumTy ap) - 9 -> do aq <- get bh - return (HsPredTy aq) - _ -> do ar <- get bh - as <- get bh - return (HsKindSig ar as) - -instance (Binary name) => Binary (HsPred name) where - put_ bh (HsClassP aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (HsIParam ac ad) = do - putByte bh 1 - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (HsClassP aa ab) - _ -> do ac <- get bh - ad <- get bh - return (HsIParam ac ad) - -instance (Binary name) => Binary (UfExpr name) where - put_ bh (UfVar aa) = do - putByte bh 0 - put_ bh aa - put_ bh (UfType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (UfTuple ac ad) = do - putByte bh 2 - put_ bh ac - put_ bh ad - put_ bh (UfLam ae af) = do - putByte bh 3 - put_ bh ae - put_ bh af - put_ bh (UfApp ag ah) = do - putByte bh 4 - put_ bh ag - put_ bh ah - put_ bh (UfCase ai aj ak) = do - putByte bh 5 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (UfLet al am) = do - putByte bh 6 - put_ bh al - put_ bh am - put_ bh (UfNote an ao) = do - putByte bh 7 - put_ bh an - put_ bh ao - put_ bh (UfLit ap) = do - putByte bh 8 - put_ bh ap - put_ bh (UfFCall as at) = do - putByte bh 9 - put_ bh as - put_ bh at - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UfVar aa) - 1 -> do ab <- get bh - return (UfType ab) - 2 -> do ac <- get bh - ad <- get bh - return (UfTuple ac ad) - 3 -> do ae <- get bh - af <- get bh - return (UfLam ae af) - 4 -> do ag <- get bh - ah <- get bh - return (UfApp ag ah) - 5 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (UfCase ai aj ak) - 6 -> do al <- get bh - am <- get bh - return (UfLet al am) - 7 -> do an <- get bh - ao <- get bh - return (UfNote an ao) - 8 -> do ap <- get bh - return (UfLit ap) - _ -> do as <- get bh - at <- get bh - return (UfFCall as at) - -instance (Binary name) => Binary (UfConAlt name) where - put_ bh UfDefault = do - putByte bh 0 - put_ bh (UfDataAlt aa) = do - putByte bh 1 - put_ bh aa - put_ bh (UfTupleAlt ab) = do - putByte bh 2 - put_ bh ab - put_ bh (UfLitAlt ac) = do - putByte bh 3 - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do return UfDefault - 1 -> do aa <- get bh - return (UfDataAlt aa) - 2 -> do ab <- get bh - return (UfTupleAlt ab) - _ -> do ac <- get bh - return (UfLitAlt ac) - -instance (Binary name) => Binary (UfBinding name) where - put_ bh (UfNonRec aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (UfRec ac) = do - putByte bh 1 - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (UfNonRec aa ab) - _ -> do ac <- get bh - return (UfRec ac) - -instance (Binary name) => Binary (UfBinder name) where - put_ bh (UfValBinder aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (UfTyBinder ac ad) = do - putByte bh 1 - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (UfValBinder aa ab) - _ -> do ac <- get bh - ad <- get bh - return (UfTyBinder ac ad) - -instance (Binary name) => Binary (HsIdInfo name) where - put_ bh (HsArity aa) = do - putByte bh 0 - put_ bh aa - put_ bh (HsStrictness ab) = do - putByte bh 1 - put_ bh ab - put_ bh (HsUnfold ac ad) = do - putByte bh 2 - put_ bh ac - put_ bh ad - put_ bh HsNoCafRefs = do - putByte bh 3 - put_ bh (HsWorker ae af) = do - putByte bh 4 - put_ bh ae - put_ bh af - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (HsArity aa) - 1 -> do ab <- get bh - return (HsStrictness ab) - 2 -> do ac <- get bh - ad <- get bh - return (HsUnfold ac ad) - 3 -> do return HsNoCafRefs - _ -> do ae <- get bh - af <- get bh - return (HsWorker ae af) - -instance (Binary name) => Binary (UfNote name) where - put_ bh (UfSCC aa) = do - putByte bh 0 - put_ bh aa - put_ bh (UfCoerce ab) = do - putByte bh 1 - put_ bh ab - put_ bh UfInlineCall = do - putByte bh 2 - put_ bh UfInlineMe = do - putByte bh 3 - put_ bh (UfCoreNote s) = do - putByte bh 4 - put_ bh s - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UfSCC aa) - 1 -> do ab <- get bh - return (UfCoerce ab) - 2 -> do return UfInlineCall - 3 -> do return UfInlineMe - _ -> do ac <- get bh - return (UfCoreNote ac) - -instance (Binary name) => Binary (BangType name) where - put_ bh (BangType aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (BangType aa ab) - -instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where - put_ bh (PrefixCon aa) = do - putByte bh 0 - put_ bh aa - put_ bh (InfixCon ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - put_ bh (RecCon ad) = do - putByte bh 2 - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (PrefixCon aa) - 1 -> do ab <- get bh - ac <- get bh - return (InfixCon ab ac) - _ -> do ad <- get bh - return (RecCon ad) - -instance (Binary datacon) => Binary (DataConDetails datacon) where - put_ bh (DataCons aa) = do - putByte bh 0 - put_ bh aa - put_ bh Unknown = do - putByte bh 1 - put_ bh (HasCons ab) = do - putByte bh 2 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (DataCons aa) - 1 -> do return Unknown - _ -> do ab <- get bh - return (HasCons ab) - -instance (Binary id) => Binary (DefMeth id) where - put_ bh NoDefMeth = do - putByte bh 0 - put_ bh (DefMeth aa) = do - putByte bh 1 - put_ bh aa - put_ bh GenDefMeth = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return NoDefMeth - 1 -> do aa <- get bh - return (DefMeth aa) - _ -> do return GenDefMeth - -instance Binary IsCafCC where - put_ bh CafCC = do - putByte bh 0 - put_ bh NotCafCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - _ -> do return NotCafCC - -instance Binary IsDupdCC where - put_ bh OriginalCC = do - putByte bh 0 - put_ bh DupdCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return OriginalCC - _ -> do return DupdCC - -instance Binary CostCentre where - put_ bh NoCostCentre = do - putByte bh 0 - put_ bh (NormalCC aa ab ac ad) = do - putByte bh 1 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh ad - put_ bh (AllCafsCC ae) = do - putByte bh 2 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do return NoCostCentre - 1 -> do aa <- get bh - ab <- get bh - ac <- get bh - ad <- get bh - return (NormalCC aa ab ac ad) - _ -> do ae <- get bh - return (AllCafsCC ae) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 153c058c02..7a4799bc5b 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -246,6 +246,7 @@ data DynFlag | Opt_D_dump_stix | Opt_D_dump_simpl_stats | Opt_D_dump_tc_trace + | Opt_D_dump_if_trace | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 28bb2857a9..701f2ba586 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.126 2003/09/24 13:04:50 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.127 2003/10/09 11:58:56 simonpj Exp $ -- -- Driver flags -- @@ -371,6 +371,7 @@ dynamic_flags = [ , ( "ddump-worker-wrapper", NoArg (setDynFlag Opt_D_dump_worker_wrapper) ) , ( "dshow-passes", NoArg (setVerbosity "2") ) , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace) ) + , ( "ddump-if-trace", NoArg (setDynFlag Opt_D_dump_if_trace) ) , ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) ) , ( "ddump-splices", NoArg (setDynFlag Opt_D_dump_splices) ) , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) ) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 87977cb1f7..e889a72845 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -41,6 +41,7 @@ import Module import ErrUtils import CmdLineOpts import Config +import RdrName ( GlobalRdrEnv ) import Panic import Util import BasicTypes ( SuccessFlag(..) ) @@ -95,29 +96,29 @@ preprocess filename = -- NB. No old interface can also mean that the source has changed. -compile :: GhciMode -- distinguish batch from interactive +compile :: HscEnv -> Module -> ModLocation -> Bool -- True <=> source unchanged -> Bool -- True <=> have object -> Maybe ModIface -- old interface, if available - -> HomePackageTable -- For home-module stuff - -> PersistentCompilerState -- persistent compiler state -> IO CompResult data CompResult - = CompOK PersistentCompilerState -- Updated PCS - ModDetails -- New details + = CompOK ModDetails -- New details + (Maybe GlobalRdrEnv) -- Lexical environment for the module + -- (Maybe because we may have loaded it from + -- its precompiled interface) ModIface -- New iface (Maybe Linkable) -- New code; Nothing => compilation was not reqd -- (old code is still valid) - | CompErrs PersistentCompilerState -- Updated PCS + | CompErrs -compile ghci_mode this_mod location +compile hsc_env this_mod location source_unchanged have_object - old_iface hpt pcs = do + old_iface = do dyn_flags <- restoreDynFlags -- Restore to the state of the last save @@ -154,20 +155,18 @@ compile ghci_mode this_mod location -- -no-recomp should also work with --make do_recomp <- readIORef v_Recomp let source_unchanged' = source_unchanged && do_recomp - hsc_env = HscEnv { hsc_mode = ghci_mode, - hsc_dflags = dyn_flags', - hsc_HPT = hpt } + hsc_env' = hsc_env { hsc_dflags = dyn_flags' } -- run the compiler - hsc_result <- hscMain hsc_env pcs this_mod location + hsc_result <- hscMain hsc_env' this_mod location source_unchanged' have_object old_iface case hsc_result of - HscFail pcs -> return (CompErrs pcs) + HscFail -> return CompErrs - HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing) + HscNoRecomp details iface -> return (CompOK details Nothing iface Nothing) - HscRecomp pcs details iface + HscRecomp details rdr_env iface stub_h_exists stub_c_exists maybe_interpreted_code -> do let maybe_stub_o <- compileStub dyn_flags' stub_c_exists @@ -202,7 +201,7 @@ compile ghci_mode this_mod location let linkable = LM unlinked_time mod_name (hs_unlinked ++ stub_unlinked) - return (CompOK pcs details iface (Just linkable)) + return (CompOK details rdr_env iface (Just linkable)) ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) @@ -620,14 +619,10 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } - hsc_env = HscEnv { hsc_mode = OneShot, - hsc_dflags = dyn_flags', - hsc_HPT = emptyHomePackageTable } - + hsc_env <- newHscEnv OneShot dyn_flags' -- run the compiler! - pcs <- initPersistentCompilerState - result <- hscMain hsc_env pcs mod + result <- hscMain hsc_env mod location{ ml_hspp_file=Just input_fn } source_unchanged False @@ -635,13 +630,14 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do case result of - HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) + HscFail -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) - HscNoRecomp pcs details iface -> do + HscNoRecomp details iface -> do SysTools.touch "Touching object file" o_file return (Nothing, Just location, output_fn) - HscRecomp _pcs _details _iface stub_h_exists stub_c_exists + HscRecomp _details _rdr_env _iface + stub_h_exists stub_c_exists _maybe_interpreted_code -> do -- deal with stubs diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 9b42afcc60..4de831c58c 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,7 +6,7 @@ \begin{code} module HscMain ( - HscResult(..), hscMain, initPersistentCompilerState + HscResult(..), hscMain, newHscEnv #ifdef GHCI , hscStmt, hscTcExpr, hscThing, , compileExpr @@ -16,7 +16,9 @@ module HscMain ( #include "HsVersions.h" #ifdef GHCI +import HsSyn ( Stmt(..) ) import TcHsSyn ( TypecheckedHsExpr ) +import IfaceSyn ( IfaceDecl ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) @@ -25,51 +27,49 @@ import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing ) import RdrHsSyn ( RdrNameStmt ) +import RdrName ( GlobalRdrEnv ) import Type ( Type ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) import SrcLoc ( noSrcLoc ) import Name ( Name ) import CoreLint ( lintUnfolding ) +import DsMeta ( templateHaskellNames ) +import BasicTypes ( Fixity ) #endif -import HsSyn - -import RdrName ( nameRdrName ) import StringBuffer ( hGetStringBuffer ) import Parser import Lexer ( P(..), ParseResult(..), mkPState, showPFailed ) import SrcLoc ( mkSrcLoc ) -import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface ) -import RnEnv ( extendOrigNameCache ) -import PrelInfo ( wiredInThingEnv, knownKeyNames ) -import PrelRules ( builtinRules ) -import MkIface ( mkIface ) +import TcRnDriver ( tcRnModule, tcRnExtCore, tcRnIface ) +import IfaceEnv ( initNameCache ) +import LoadIface ( ifaceStats, initExternalPackageState ) +import PrelInfo ( wiredInThings, basicKnownKeyNames ) +import RdrName ( GlobalRdrEnv ) +import MkIface ( checkOldIface, mkIface ) import Desugar import Flattening ( flatten ) import SimplCore import TidyPgm ( tidyCorePgm ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) +import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) -import Module ( emptyModuleEnv ) import CmdLineOpts import DriverPhases ( isExtCore_file ) -import ErrUtils ( dumpIfSet_dyn, showPass ) +import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import UniqSupply ( mkSplitUniqSupply ) -import Bag ( consBag, emptyBag ) import Outputable import HscStats ( ppSourceStats ) import HscTypes import MkExternalCore ( emitExternalCore ) import ParserCore import ParserCoreUtils -import FiniteMap ( emptyFM ) -import Name ( nameModule ) import Module ( Module, ModLocation(..), showModMsg ) import FastString import Maybes ( expectJust ) @@ -77,27 +77,58 @@ import Maybes ( expectJust ) import Monad ( when ) import Maybe ( isJust, fromJust ) import IO +import DATA_IOREF ( newIORef, readIORef ) \end{code} %************************************************************************ %* * -\subsection{The main compiler pipeline} + Initialisation +%* * +%************************************************************************ + +\begin{code} +newHscEnv :: GhciMode -> DynFlags -> IO HscEnv +newHscEnv ghci_mode dflags + = do { eps_var <- newIORef initExternalPackageState + ; us <- mkSplitUniqSupply 'r' + ; nc_var <- newIORef (initNameCache us knownKeyNames) + ; return (HscEnv { hsc_mode = ghci_mode, + hsc_dflags = dflags, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var } ) } + + +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, + -- where templateHaskellNames are defined +knownKeyNames = map getName wiredInThings + ++ basicKnownKeyNames +#ifdef GHCI + ++ templateHaskellNames +#endif +\end{code} + + +%************************************************************************ +%* * + The main compiler pipeline %* * %************************************************************************ \begin{code} data HscResult - -- compilation failed - = HscFail PersistentCompilerState -- updated PCS - -- concluded that it wasn't necessary - | HscNoRecomp PersistentCompilerState -- updated PCS - ModDetails -- new details (HomeSymbolTable additions) + -- Compilation failed + = HscFail + + -- Concluded that it wasn't necessary + | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) ModIface -- new iface (if any compilation was done) - -- did recompilation - | HscRecomp PersistentCompilerState -- updated PCS - ModDetails -- new details (HomeSymbolTable additions) - ModIface -- new iface (if any compilation was done) + + -- Did recompilation + | HscRecomp ModDetails -- new details (HomeSymbolTable additions) + (Maybe GlobalRdrEnv) + ModIface -- new iface (if any compilation was done) Bool -- stub_h exists Bool -- stub_c exists (Maybe CompiledByteCode) @@ -107,7 +138,6 @@ data HscResult hscMain :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> Module -> ModLocation -- location info -> Bool -- True <=> source unchanged @@ -115,35 +145,35 @@ hscMain -> Maybe ModIface -- old interface, if available -> IO HscResult -hscMain hsc_env pcs mod location +hscMain hsc_env mod location source_unchanged have_object maybe_old_iface = do { - (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface" - checkOldIface hsc_env pcs mod - (ml_hi_file location) - source_unchanged maybe_old_iface; - case maybe_chk_result of { - Nothing -> return (HscFail pcs_ch) ; - Just (recomp_reqd, maybe_checked_iface) -> do { + (recomp_reqd, maybe_checked_iface) <- + _scc_ "checkOldIface" + checkOldIface hsc_env mod + (ml_hi_file location) + source_unchanged maybe_old_iface; let no_old_iface = not (isJust maybe_checked_iface) what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp - ; what_next hsc_env pcs_ch have_object + ; what_next hsc_env have_object mod location maybe_checked_iface - }}} + } -- hscNoRecomp definitely expects to have the old interface available -hscNoRecomp hsc_env pcs_ch have_object +hscNoRecomp hsc_env have_object mod location (Just old_iface) | hsc_mode hsc_env == OneShot = do { when (verbosity (hsc_dflags hsc_env) > 0) $ hPutStrLn stderr "compilation IS NOT required"; + dumpIfaceStats hsc_env ; + let { bomb = panic "hscNoRecomp:OneShot" }; - return (HscNoRecomp pcs_ch bomb bomb) + return (HscNoRecomp bomb bomb) } | otherwise = do { @@ -151,18 +181,14 @@ hscNoRecomp hsc_env pcs_ch have_object hPutStrLn stderr ("Skipping " ++ showModMsg have_object mod location); - -- Typecheck - (pcs_tc, maybe_tc_result) <- _scc_ "tcRnIface" - tcRnIface hsc_env pcs_ch old_iface ; - - case maybe_tc_result of { - Nothing -> return (HscFail pcs_tc); - Just new_details -> + new_details <- _scc_ "tcRnIface" + tcRnIface hsc_env old_iface ; + dumpIfaceStats hsc_env ; - return (HscNoRecomp pcs_tc new_details old_iface) - }} + return (HscNoRecomp new_details old_iface) + } -hscRecomp hsc_env pcs_ch have_object +hscRecomp hsc_env have_object mod location maybe_checked_iface = do { -- what target are we shooting for? @@ -177,13 +203,13 @@ hscRecomp hsc_env pcs_ch have_object showModMsg (not toInterp) mod location); ; front_res <- if toCore then - hscCoreFrontEnd hsc_env pcs_ch location + hscCoreFrontEnd hsc_env location else - hscFrontEnd hsc_env pcs_ch location + hscFrontEnd hsc_env location ; case front_res of Left flure -> return flure; - Right (pcs_tc, ds_result) -> do { + Right ds_result -> do { -- OMITTED: @@ -193,11 +219,15 @@ hscRecomp hsc_env pcs_ch have_object -- FLATTENING ------------------- ; flat_result <- _scc_ "Flattening" - flatten hsc_env pcs_tc ds_result + flatten hsc_env ds_result + +{- TEMP: need to review space-leak fixing here + NB: even the code generator can force one of the + thunks for constructor arguments, for newtypes in particular ; let -- Rule-base accumulated from imported packages - pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc) + pkg_rule_base = eps_rule_base (hsc_EPS hsc_env) -- In one-shot mode, ZAP the external package state at -- this point, because we aren't going to need it from @@ -208,6 +238,7 @@ hscRecomp hsc_env pcs_ch have_object | otherwise = pcs_tc ; pkg_rule_base `seq` pcs_middle `seq` return () +-} -- alive at this point: -- pcs_middle @@ -217,21 +248,16 @@ hscRecomp hsc_env pcs_ch have_object ------------------- -- SIMPLIFY ------------------- - ; simpl_result <- _scc_ "Core2Core" - core2core hsc_env pkg_rule_base flat_result + ; simpl_result <- _scc_ "Core2Core" + core2core hsc_env flat_result ------------------- -- TIDY ------------------- - ; (pcs_simpl, tidy_result) - <- _scc_ "CoreTidy" - tidyCorePgm dflags pcs_middle simpl_result - - -- ZAP the persistent compiler state altogether now if we're - -- in one-shot mode, to save space. - ; pcs_final <- if one_shot then return (error "pcs_final missing") - else return pcs_simpl + ; tidy_result <- _scc_ "CoreTidy" + tidyCorePgm hsc_env simpl_result + -- Emit external core ; emitExternalCore dflags tidy_result -- Alive at this point: @@ -255,6 +281,9 @@ hscRecomp hsc_env pcs_ch have_object ; final_iface <- if one_shot then return (error "no final iface") else return new_iface + ; let { final_globals | one_shot = Nothing + | otherwise = Just $! (mg_rdr_env tidy_result) } + ; final_globals `seq` return () -- Build the final ModDetails (except in one-shot mode, where -- we won't need this information after compilation). @@ -270,36 +299,38 @@ hscRecomp hsc_env pcs_ch have_object ; (stub_h_exists, stub_c_exists, maybe_bcos) <- hscBackEnd dflags tidy_result - -- and the answer is ... - ; return (HscRecomp pcs_final - final_details + -- And the answer is ... + ; dumpIfaceStats hsc_env + + ; return (HscRecomp final_details + final_globals final_iface stub_h_exists stub_c_exists maybe_bcos) }} -hscCoreFrontEnd hsc_env pcs_ch location = do { +hscCoreFrontEnd hsc_env location = do { ------------------- -- PARSE ------------------- ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location)) ; case parseCore inp 1 of - FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch)); + FailP s -> hPutStrLn stderr s >> return (Left HscFail); OkP rdr_module -> do { ------------------- -- RENAME and TYPECHECK ------------------- - ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck" - tcRnExtCore hsc_env pcs_ch rdr_module + ; maybe_tc_result <- _scc_ "TypeCheck" + tcRnExtCore hsc_env rdr_module ; case maybe_tc_result of { - Nothing -> return (Left (HscFail pcs_tc)); - Just mod_guts -> return (Right (pcs_tc, mod_guts)) + Nothing -> return (Left HscFail); + Just mod_guts -> return (Right mod_guts) -- No desugaring to do! }}} -hscFrontEnd hsc_env pcs_ch location = do { +hscFrontEnd hsc_env location = do { ------------------- -- PARSE ------------------- @@ -307,26 +338,26 @@ hscFrontEnd hsc_env pcs_ch location = do { (expectJust "hscFrontEnd:hspp" (ml_hspp_file location)) ; case maybe_parsed of { - Nothing -> return (Left (HscFail pcs_ch)); + Nothing -> return (Left HscFail); Just rdr_module -> do { ------------------- -- RENAME and TYPECHECK ------------------- - ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename" - tcRnModule hsc_env pcs_ch rdr_module + ; maybe_tc_result <- _scc_ "Typecheck-Rename" + tcRnModule hsc_env rdr_module ; case maybe_tc_result of { - Nothing -> return (Left (HscFail pcs_ch)); + Nothing -> return (Left HscFail); Just tc_result -> do { ------------------- -- DESUGAR ------------------- ; maybe_ds_result <- _scc_ "DeSugar" - deSugar hsc_env pcs_tc tc_result + deSugar hsc_env tc_result ; case maybe_ds_result of - Nothing -> return (Left (HscFail pcs_ch)); - Just ds_result -> return (Right (pcs_tc, ds_result)); + Nothing -> return (Left HscFail); + Just ds_result -> return (Right ds_result); }}}}} @@ -393,7 +424,7 @@ myParseModule dflags src_filename case unP parseModule (mkPState buf loc dflags) of { - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing }; POk _ rdr_module -> do { @@ -456,50 +487,47 @@ A naked expression returns a singleton Name [it]. #ifdef GHCI hscStmt -- Compile a stmt all the way to an HValue, but don't run it :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The statement - -> IO ( PersistentCompilerState, - Maybe (InteractiveContext, [Name], HValue) ) + -> IO (Maybe (InteractiveContext, [Name], HValue)) -hscStmt hsc_env pcs icontext stmt +hscStmt hsc_env icontext stmt = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt ; case maybe_stmt of { - Nothing -> return (pcs, Nothing) ; + Nothing -> return Nothing ; Just parsed_stmt -> do { -- Rename and typecheck it - (pcs1, maybe_tc_result) - <- tcRnStmt hsc_env pcs icontext parsed_stmt + maybe_tc_result + <- tcRnStmt hsc_env icontext parsed_stmt ; case maybe_tc_result of { - Nothing -> return (pcs1, Nothing) ; + Nothing -> return Nothing ; Just (new_ic, bound_names, tc_expr) -> do { -- Then desugar, code gen, and link it - ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE + ; hval <- compileExpr hsc_env iNTERACTIVE (ic_rn_gbl_env new_ic) (ic_type_env new_ic) tc_expr - ; return (pcs1, Just (new_ic, bound_names, hval)) + ; return (Just (new_ic, bound_names, hval)) }}}}} hscTcExpr -- Typecheck an expression (but don't run it) :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The expression - -> IO (PersistentCompilerState, Maybe Type) + -> IO (Maybe Type) -hscTcExpr hsc_env pcs icontext expr +hscTcExpr hsc_env icontext expr = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr ; case maybe_stmt of { Just (ExprStmt expr _ _) - -> tcRnExpr hsc_env pcs icontext expr ; + -> tcRnExpr hsc_env icontext expr ; Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ; - return (pcs, Nothing) } ; - Nothing -> return (pcs, Nothing) } } + return Nothing } ; + Nothing -> return Nothing } } \end{code} \begin{code} @@ -514,7 +542,7 @@ hscParseStmt dflags str case unP parseStmt (mkPState buf loc dflags) of { - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing }; -- no stmt: the line consisted of just space or comments @@ -540,26 +568,21 @@ hscParseStmt dflags str #ifdef GHCI hscThing -- like hscStmt, but deals with a single identifier :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The identifier - -> IO ( PersistentCompilerState, - [TyThing] ) - -hscThing hsc_env pcs0 ic str - = do let dflags = hsc_dflags hsc_env + -> IO [(IfaceDecl, Fixity)] - maybe_rdr_name <- myParseIdentifier dflags str +hscThing hsc_env ic str + = do maybe_rdr_name <- myParseIdentifier (hsc_dflags hsc_env) str case maybe_rdr_name of { - Nothing -> return (pcs0, []); + Nothing -> return []; Just rdr_name -> do - (pcs1, maybe_tc_result) <- - tcRnThing hsc_env pcs0 ic rdr_name + maybe_tc_result <- tcRnThing hsc_env ic rdr_name case maybe_tc_result of { - Nothing -> return (pcs1, []) ; - Just things -> return (pcs1, things) + Nothing -> return [] ; + Just things -> return things }} myParseIdentifier dflags str @@ -568,7 +591,7 @@ myParseIdentifier dflags str let loc = mkSrcLoc FSLIT("<interactive>") 1 0 case unP parseIdentifier (mkPState buf loc dflags) of - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing } POk _ rdr_name -> return (Just rdr_name) @@ -584,20 +607,19 @@ myParseIdentifier dflags str \begin{code} #ifdef GHCI compileExpr :: HscEnv - -> PersistentCompilerState -> Module -> GlobalRdrEnv -> TypeEnv -> TypecheckedHsExpr -> IO HValue -compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr +compileExpr hsc_env this_mod rdr_env type_env tc_expr = do { let { dflags = hsc_dflags hsc_env ; lint_on = dopt Opt_DoCoreLinting dflags } -- Desugar it - ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr + ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr -- Flatten it - ; flat_expr <- flattenExpr hsc_env pcs ds_expr + ; flat_expr <- flattenExpr hsc_env ds_expr -- Simplify it ; simpl_expr <- simplifyExpr dflags flat_expr @@ -621,7 +643,7 @@ compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr ; bcos <- coreExprToBCOs dflags prepd_expr -- link it - ; hval <- linkExpr hsc_env pcs bcos + ; hval <- linkExpr hsc_env bcos ; return hval } @@ -631,40 +653,19 @@ compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr %************************************************************************ %* * -\subsection{Initial persistent state} + Statistics on reading interfaces %* * %************************************************************************ \begin{code} -initPersistentCompilerState :: IO PersistentCompilerState -initPersistentCompilerState - = do nc <- initNameCache - return ( - PCS { pcs_EPS = initExternalPackageState, - pcs_nc = nc }) - -initNameCache :: IO NameCache - = do us <- mkSplitUniqSupply 'r' - return (NameCache { nsUniqs = us, - nsNames = initOrigNames, - nsIPs = emptyFM }) - -initExternalPackageState :: ExternalPackageState -initExternalPackageState - = emptyExternalPackageState { - eps_rules = foldr add_rule (emptyBag, 0) builtinRules, - eps_PTE = wiredInThingEnv, - } +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env + = do { eps <- readIORef (hsc_EPS hsc_env) + ; dumpIfSet (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) } where - add_rule (name,rule) (rules, n_slurped) - = (gated_decl `consBag` rules, n_slurped) - where - gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule)) - mod = nameModule name - rdr_name = nameRdrName name -- Seems a bit of a hack to go back - -- to the RdrName - gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible - -initOrigNames :: OrigNameCache -initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags \end{code} diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 8e59f3c16f..e830170f58 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -9,7 +9,6 @@ module HscStats ( ppSourceStats ) where #include "HsVersions.h" import HsSyn -import TyCon ( DataConDetails(..) ) import Outputable import Char ( isSpace ) import Util ( count ) @@ -64,13 +63,13 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - (fixity_sigs, bind_tys, _, bind_specs, bind_inlines) + (fixity_sigs, bind_tys, bind_specs, bind_inlines) = count_sigs [d | SigD d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, data_ds, newt_ds, type_ds, _) = countTyClDecls tycl_decls + (class_ds, type_ds, data_ds, newt_ds) = countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] inst_ds = length inst_decls @@ -102,17 +101,13 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) count_monobinds (PatMonoBind p r _) = (0,1) count_monobinds (FunMonoBind f _ m _) = (0,1) - count_mb_monobinds (Just mbs) = count_monobinds mbs - count_mb_monobinds Nothing = (0,0) + count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) - count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) - - sig_info (FixSig _) = (1,0,0,0,0) - sig_info (Sig _ _ _) = (0,1,0,0,0) - sig_info (ClassOpSig _ _ _ _) = (0,0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,0,1,0) - sig_info (InlineSig _ _ _ _) = (0,0,0,0,1) - sig_info _ = (0,0,0,0,0) + sig_info (FixSig _) = (1,0,0,0) + sig_info (Sig _ _ _) = (0,1,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0) + sig_info (InlineSig _ _ _ _) = (0,0,0,1) + sig_info _ = (0,0,0,0) import_info (ImportDecl _ _ qual as spec _) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) @@ -124,35 +119,31 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) spec_info (Just (False, _)) = (0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,1) - data_info (TyData {tcdCons = DataCons cs, tcdDerivs = derivs}) + data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) = (length cs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) class_info decl@(ClassDecl {}) = case count_sigs (tcdSigs decl) of - (_,_,classops,_,_) -> - (classops, addpr (count_mb_monobinds (tcdMeths decl))) + (_,classops,_,_) -> + (classops, addpr (count_monobinds (tcdMeths decl))) class_info other = (0,0) - inst_info (InstDecl _ inst_meths inst_sigs _ _) + inst_info (InstDecl _ inst_meths inst_sigs _) = case count_sigs inst_sigs of - (_,_,_,ss,is) -> + (_,_,ss,is) -> (addpr (count_monobinds inst_meths), ss, is) addpr :: (Int,Int) -> Int - add1 :: Int -> Int -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) add3 :: (Int,Int,Int) -> (Int,Int,Int) -> (Int, Int, Int) add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int) - add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int) addpr (x,y) = x+y - add1 x1 y1 = x1+y1 add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4) - add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6) \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 88fd6b9562..7cb86bfb42 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -1,64 +1,59 @@ -% + % (c) The University of Glasgow, 2000 % \section[HscTypes]{Types for the per-module compiler} \begin{code} module HscTypes ( - HscEnv(..), + HscEnv(..), hscEPS, GhciMode(..), - ModDetails(..), ModIface(..), + ModDetails(..), ModGuts(..), ModImports(..), ForeignStubs(..), - ParsedIface(..), IfaceDeprecs, HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - ExternalPackageState(..), emptyExternalPackageState, + ExternalPackageState(..), PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, lookupIface, lookupIfaceByModName, moduleNameToModule, emptyModIface, - InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, unQualInScope, + + ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, + emptyIfaceDepCache, - IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, + Deprecs(..), IfaceDeprecs, - VersionInfo(..), initialVersionInfo, lookupVersion, - FixityEnv, lookupFixity, collectFixities, emptyFixityEnv, + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - TyThing(..), implicitTyThings, + implicitTyThings, isImplicitTyThing, + TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, - extendTypeEnvList, extendTypeEnvWithIds, + extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, - WhetherHasOrphans, IsBootInterface, DeclsMap, Usage(..), + WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, + Pool(..), emptyPool, DeclPool, InstPool, + Gated, + RulePool, addRuleToPool, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, - ExportItem, RdrExportItem, + IfaceExport, - PersistentCompilerState(..), + Deprecations, DeprecTxt, lookupDeprec, plusDeprecs, - Deprecations(..), lookupDeprec, plusDeprecs, - - InstEnv, ClsInstEnv, DFunId, + InstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, GlobalRdrElt(..), emptyGlobalRdrEnv, pprGlobalRdrEnv, - LocalRdrEnv, extendLocalRdrEnv, isLocalGRE, unQualInScope, - -- Linker stuff Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, - isObject, nameOfObject, isInterpretable, byteCodeOfObject, - - -- Provenance - Provenance(..), ImportReason(..), - pprNameProvenance, hasBetterProv - + isObject, nameOfObject, isInterpretable, byteCodeOfObject ) where #include "HsVersions.h" @@ -67,48 +62,43 @@ module HscTypes ( import ByteCodeAsm ( CompiledByteCode ) #endif -import RdrName ( RdrName, mkRdrUnqual, - RdrNameEnv, addListToRdrEnv, foldRdrEnv, isUnqual, - rdrEnvToList, emptyRdrEnv ) -import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) +import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, + LocalRdrEnv, emptyLocalRdrEnv, + GlobalRdrElt(..), unQualOK ) +import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet -import OccName ( OccName ) +import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, + extendOccEnv, foldOccEnv ) import Module -import InstEnv ( InstEnv, ClsInstEnv, DFunId ) +import InstEnv ( InstEnv, DFunId ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) -import Id ( Id, idName ) +import Id ( Id, isImplicitId ) +import Type ( TyThing(..) ) + import Class ( Class, classSelIds, classTyCon ) -import TyCon ( TyCon, tyConName, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons ) -import TcType ( TyThing(..) ) -import DataCon ( dataConWorkId, dataConWrapId, dataConWrapId_maybe ) -import Packages ( PackageName, basePackage ) +import TyCon ( TyCon, isClassTyCon, tyConSelIds, tyConDataCons ) +import DataCon ( dataConImplicitIds ) +import Packages ( PackageName ) import CmdLineOpts ( DynFlags ) -import BasicTypes ( Version, initialVersion, IPName, - Fixity, FixitySig(..), defaultFixity ) +import BasicTypes ( Version, initialVersion, IPName, + Fixity, defaultFixity, DeprecTxt ) -import HsSyn ( DeprecTxt, TyClDecl, InstDecl, RuleDecl, - tyClDeclName, ifaceRuleDeclName, tyClDeclNames, - instDeclDFun ) -import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) +import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) +import FiniteMap ( FiniteMap ) import CoreSyn ( IdCoreRule ) import PrelNames ( isBuiltInSyntaxName ) -import InstEnv ( emptyInstEnv ) -import Rules ( emptyRuleBase ) - -import FiniteMap -import Bag ( Bag, emptyBag ) import Maybes ( orElse ) import Outputable -import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import Util ( thenCmp, sortLt ) +import SrcLoc ( SrcLoc ) import UniqSupply ( UniqSupply ) import Maybe ( fromJust ) import FastString ( FastString ) +import DATA_IOREF ( IORef, readIORef ) import Time ( ClockTime ) \end{code} @@ -122,9 +112,28 @@ import Time ( ClockTime ) The HscEnv gives the environment in which to compile a chunk of code. \begin{code} -data HscEnv = HscEnv { hsc_mode :: GhciMode, - hsc_dflags :: DynFlags, - hsc_HPT :: HomePackageTable } +data HscEnv + = HscEnv { hsc_mode :: GhciMode, + hsc_dflags :: DynFlags, + + hsc_HPT :: HomePackageTable, + -- The home package table describes already-compiled + -- home-packge modules, *excluding* the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as "external-package" modules.) + -- hsc_HPT is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded by the compilation manager. + + -- The next two are side-effected by compiling + -- to reflect sucking in interface files + hsc_EPS :: IORef ExternalPackageState, + hsc_NC :: IORef NameCache } + +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) \end{code} The GhciMode is self-explanatory: @@ -141,9 +150,12 @@ type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported emptyHomePackageTable = emptyModuleEnv emptyPackageIfaceTable = emptyModuleEnv -data HomeModInfo = HomeModInfo { hm_iface :: ModIface, - hm_details :: ModDetails, - hm_linkable :: Linkable } +data HomeModInfo + = HomeModInfo { hm_iface :: ModIface, + hm_globals :: Maybe GlobalRdrEnv, -- Its top level environment + -- Nothing <-> compiled module + hm_details :: ModDetails, + hm_linkable :: Linkable } \end{code} Simple lookups in the symbol table. @@ -192,38 +204,58 @@ the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface = ModIface { - mi_module :: !Module, mi_package :: !PackageName, -- Which package the module comes from - mi_version :: !VersionInfo, -- Version info for everything in this module + mi_module :: !Module, + mi_mod_vers :: !Version, -- Module version: changes when anything changes + mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans mi_boot :: !IsBootInterface, -- Read from an hi-boot file? mi_deps :: Dependencies, - -- This is consulted for directly-imported modules, but - -- not for anything else + -- This is consulted for directly-imported modules, + -- but not for anything else (hence lazy) - mi_usages :: [Usage Name], -- Usages; kept sorted so that it's easy to decide -- whether to write a new iface file (changing usages -- doesn't affect the version of this module) + mi_usages :: [Usage], -- NOT STRICT! we read this field lazily from the interface file -- It is *only* consulted by the recompilation checker - mi_exports :: ![ExportItem], - -- What it exports Kept sorted by (mod,occ), to make - -- version comparisons easier + -- Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + mi_exports :: ![IfaceExport], + mi_exp_vers :: !Version, -- Version number of export list - mi_globals :: !(Maybe GlobalRdrEnv), - -- Its top level environment or Nothing if we read this - -- interface from an interface file. (We need the source - -- file to figure out the top-level environment.) + -- Fixities + mi_fixities :: [(OccName,Fixity)], + -- NOT STRICT! we read this field lazily from the interface file - mi_fixities :: !FixityEnv, -- Fixities - mi_deprecs :: Deprecations, -- Deprecations - -- NOT STRICT! we read this field lazilly from the interface file + -- Deprecations + mi_deprecs :: Deprecs [(OccName,DeprecTxt)], + -- NOT STRICT! we read this field lazily from the interface file - mi_decls :: IfaceDecls -- The RnDecls form of ModDetails - -- NOT STRICT! we fill this field with _|_ sometimes + -- Type, class and variable declarations + -- The version of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the version of the parent class/tycon changes + mi_decls :: [(Version,IfaceDecl)], -- Sorted + + -- Instance declarations and rules + mi_insts :: [IfaceInst], -- Sorted + mi_rules :: [IfaceRule], -- Sorted + mi_rule_vers :: !Version, -- Version number for rules and instances combined + + -- Cached environments for easy lookup + -- These are computed (lazily) from other fields + -- and are not put into the interface file + mi_dep_fn :: Name -> Maybe DeprecTxt, -- Cached lookup for mi_deprecs + mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities + mi_ver_fn :: OccName -> Maybe Version -- Cached lookup for mi_decls + -- The Nothing in mi_ver_fn means that the thing + -- isn't in decls. It's useful to know that when + -- seeing if we are up to date wrt the old interface } -- Should be able to construct ModDetails from mi_decls in ModIface @@ -247,7 +279,7 @@ data ModGuts mg_deps :: !Dependencies, -- What is below it, directly or otherwise mg_dir_imps :: ![Module], -- Directly-imported modules; used to -- generate initialisation code - mg_usages :: ![Usage Name], -- Version info for what it needed + mg_usages :: ![Usage], -- Version info for what it needed mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module @@ -305,76 +337,35 @@ data ForeignStubs = NoStubs [Id] -- Foreign-exported binders -- we have to generate code to register these - -data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted - dcl_rules :: [RenamedRuleDecl], -- Sorted - dcl_insts :: [RenamedInstDecl] } -- Unsorted - -mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls --- Sort to put them in canonical order for version comparison -mkIfaceDecls tycls rules insts - = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls, - dcl_rules = sortLt lt_rule rules, - dcl_insts = sortLt lt_inst insts } - where - d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2 - r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2 - i1 `lt_inst` i2 = instDeclDFun i1 < instDeclDFun i2 \end{code} \begin{code} -emptyModIface :: Module -> ModIface -emptyModIface mod - = ModIface { mi_module = mod, - mi_package = basePackage, -- XXX fully bogus - mi_version = initialVersionInfo, - mi_usages = [], - mi_deps = noDependencies, +emptyModIface :: PackageName -> ModuleName -> ModIface +emptyModIface pkg mod + = ModIface { mi_package = pkg, + mi_module = mkModule pkg mod, + mi_mod_vers = initialVersion, mi_orphan = False, mi_boot = False, + mi_deps = noDependencies, + mi_usages = [], mi_exports = [], - mi_fixities = emptyNameEnv, - mi_globals = Nothing, + mi_exp_vers = initialVersion, + mi_fixities = [], mi_deprecs = NoDeprecs, - mi_decls = panic "emptyModIface: decls" + mi_insts = [], + mi_rules = [], + mi_decls = [], + mi_rule_vers = initialVersion, + mi_dep_fn = emptyIfaceDepCache, + mi_fix_fn = emptyIfaceFixCache, + mi_ver_fn = emptyIfaceVerCache } \end{code} %************************************************************************ %* * - Parsed interface files -%* * -%************************************************************************ - -A ParsedIface is exactly as read from an interface file. - -\begin{code} -type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)]) - -- Nothing => NoDeprecs - -- Just (Left t) => DeprecAll - -- Just (Right p) => DeprecSome - -data ParsedIface - = ParsedIface { - pi_mod :: ModuleName, - pi_pkg :: PackageName, - pi_vers :: Version, -- Module version number - pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans - pi_deps :: Dependencies, -- What it depends on - pi_usages :: [Usage OccName], -- Usages - pi_exports :: (Version, [RdrExportItem]), -- Exports - pi_decls :: [(Version, TyClDecl RdrName)], -- Local definitions - pi_fixity :: [FixitySig RdrName], -- Local fixity declarations, - pi_insts :: [InstDecl RdrName], -- Local instance declarations - pi_rules :: (Version, [RuleDecl RdrName]), -- Rules, with their version - pi_deprecs :: IfaceDeprecs -- Deprecations - } -\end{code} - - -%************************************************************************ -%* * \subsection{The interactive context} %* * %************************************************************************ @@ -382,10 +373,10 @@ data ParsedIface \begin{code} data InteractiveContext = InteractiveContext { - ic_toplev_scope :: [Module], -- Include the "top-level" scope of + ic_toplev_scope :: [String], -- Include the "top-level" scope of -- these modules - ic_exports :: [Module], -- Include just the exports of these + ic_exports :: [String], -- Include just the exports of these -- modules ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from @@ -400,86 +391,111 @@ data InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], ic_exports = [], - ic_rn_gbl_env = emptyRdrEnv, - ic_rn_local_env = emptyRdrEnv, + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_rn_local_env = emptyLocalRdrEnv, ic_type_env = emptyTypeEnv } icPrintUnqual :: InteractiveContext -> PrintUnqualified icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt) \end{code} +@unQualInScope@ returns a function that takes a @Name@ and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the @Name@'s provenance to guide whether or not to print the name qualified +in error messages. + +\begin{code} +unQualInScope :: GlobalRdrEnv -> Name -> Bool +-- True if 'f' is in scope, and has only one binding, +-- and the thing it is bound to is the name we are looking for +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') +-- +-- Also checks for built-in syntax, which is always 'in scope' +-- +-- This fn is only efficient if the shared +-- partial application is used a lot. +unQualInScope env + = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n + where + unqual_names :: NameSet + unqual_names = foldOccEnv add emptyNameSet env + add [gre] unquals | unQualOK gre = addOneToNameSet unquals (gre_name gre) + add _ unquals = unquals +\end{code} + %************************************************************************ %* * -\subsection{Type environment stuff} + TyThing %* * %************************************************************************ \begin{code} +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (ADataCon dc) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isClassTyCon tc +isImplicitTyThing other = False + +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId id) = [] + + -- For type constructors, add the data cons (and their extras), + -- and the selectors and generic-programming Ids too + -- + -- Newtypes don't have a worker Id, so don't generate that? +implicitTyThings (ATyCon tc) = map AnId (tyConSelIds tc) ++ + concatMap (extras_plus . ADataCon) (tyConDataCons tc) + + -- For classes, add the class TyCon too (and its extras) + -- and the class selector Ids +implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ + extras_plus (ATyCon (classTyCon cl)) + + + -- For data cons add the worker and wrapper (if any) +implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) + +extras_plus thing = thing : implicitTyThings thing + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] +\end{code} + +%************************************************************************ +%* * + TypeEnv +%* * +%************************************************************************ + +\begin{code} +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv typeEnvElts :: TypeEnv -> [TyThing] typeEnvClasses :: TypeEnv -> [Class] typeEnvTyCons :: TypeEnv -> [TyCon] typeEnvIds :: TypeEnv -> [Id] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing +emptyTypeEnv = emptyNameEnv typeEnvElts env = nameEnvElts env typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] -\end{code} - - -\begin{code} -type TypeEnv = NameEnv TyThing - -emptyTypeEnv = emptyNameEnv mkTypeEnv :: [TyThing] -> TypeEnv mkTypeEnv things = extendTypeEnvList emptyTypeEnv things +lookupTypeEnv = lookupNameEnv + extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv -- Extend the type environment extendTypeEnvList env things = foldl extend env things where extend env thing = extendNameEnv env (getName thing) thing - -implicitTyThings :: [TyThing] -> [TyThing] -implicitTyThings things - = concatMap extras things - where - extras_plus thing = thing : extras thing - - extras (AnId id) = [] - - -- For type constructors, add the data cons (and their extras), - -- and the selectors and generic-programming Ids too - -- - -- Newtypes don't have a worker Id, so don't generate that - extras (ATyCon tc) = map AnId (tyConGenIds tc ++ tyConSelIds tc) ++ data_con_stuff - where - data_con_stuff | isNewTyCon tc = (if (null dcs) then [] else [ADataCon dc1, AnId (dataConWrapId dc1)]) - | otherwise = concatMap (extras_plus . ADataCon) dcs - dcs = tyConDataCons tc - dc1 = head dcs - - -- For classes, add the class TyCon too (and its extras) - -- and the class selector Ids - extras (AClass cl) = map AnId (classSelIds cl) ++ - extras_plus (ATyCon (classTyCon cl)) - - - -- For data cons add the worker and wrapper (if any) - extras (ADataCon dc) - = AnId (dataConWorkId dc) : wrap_id_stuff - where - -- May or may not have a wrapper - wrap_id_stuff = case dataConWrapId_maybe dc of - Just id -> [AnId id] - Nothing -> [] - -extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv -extendTypeEnvWithIds env ids - = extendNameEnvList env [(getName id, AnId id) | id <- ids] \end{code} \begin{code} @@ -490,6 +506,21 @@ lookupType hpt pte name Nothing -> lookupNameEnv pte name \end{code} + +\begin{code} +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +tyThingClass (AClass cls) = cls +tyThingClass other = pprPanic "tyThingClass" (ppr other) + +tyThingDataCon (ADataCon dc) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +tyThingId (AnId id) = id +tyThingId other = pprPanic "tyThingId" (ppr other) +\end{code} + %************************************************************************ %* * \subsection{Auxiliary types} @@ -500,35 +531,33 @@ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere \begin{code} -data VersionInfo - = VersionInfo { - vers_module :: Version, -- Changes when anything changes - vers_exports :: Version, -- Changes when export list changes - vers_rules :: Version, -- Changes when any rule changes - vers_decls :: NameEnv Version - -- Versions for "big" names only (not data constructors, class ops) - -- The version of an Id changes if its fixity changes - -- Ditto data constructors, class operations, except that the version of - -- the parent class/tycon changes - -- - -- If a name isn't in the map, it means 'initialVersion' - } +mkIfaceVerCache :: [(Version,IfaceDecl)] -> OccName -> Maybe Version +mkIfaceVerCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl add emptyOccEnv pairs + add env (v,d) = extendOccEnv env (ifName d) v + +emptyIfaceVerCache :: OccName -> Maybe Version +emptyIfaceVerCache occ = Nothing + +------------------ Deprecations ------------------------- +data Deprecs a + = NoDeprecs + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome a -- Some specific things deprecated + deriving( Eq ) -initialVersionInfo :: VersionInfo -initialVersionInfo = VersionInfo { vers_module = initialVersion, - vers_exports = initialVersion, - vers_rules = initialVersion, - vers_decls = emptyNameEnv - } +type IfaceDeprecs = Deprecs [(OccName,DeprecTxt)] +type Deprecations = Deprecs (NameEnv (OccName,DeprecTxt)) -lookupVersion :: NameEnv Version -> Name -> Version -lookupVersion env name = lookupNameEnv env name `orElse` initialVersion +mkIfaceDepCache:: IfaceDeprecs -> Name -> Maybe DeprecTxt +mkIfaceDepCache NoDeprecs = \n -> Nothing +mkIfaceDepCache (DeprecAll t) = \n -> Just t +mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName -data Deprecations = NoDeprecs - | DeprecAll DeprecTxt -- Whole module deprecated - | DeprecSome (NameEnv (Name,DeprecTxt)) -- Some things deprecated - -- Just "big" names - -- We keep the Name in the range, so we can print them out +emptyIfaceDepCache :: Name -> Maybe DeprecTxt +emptyIfaceDepCache n = Nothing lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt lookupDeprec NoDeprecs name = Nothing @@ -543,13 +572,6 @@ plusDeprecs NoDeprecs d = d plusDeprecs d (DeprecAll t) = DeprecAll t plusDeprecs (DeprecAll t) d = DeprecAll t plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) - -instance Eq Deprecations where - -- Used when checking whether we need write a new interface - NoDeprecs == NoDeprecs = True - (DeprecAll t1) == (DeprecAll t2) = t1 == t2 - (DeprecSome e1) == (DeprecSome e2) = nameEnvElts e1 == nameEnvElts e2 - d1 == d2 = False \end{code} @@ -567,8 +589,7 @@ data GenAvailInfo name = Avail name -- An ordinary identifier deriving( Eq ) -- Equality used when deciding if the interface has changed -type RdrExportItem = (ModuleName, [RdrAvailInfo]) -type ExportItem = (ModuleName, [AvailInfo]) +type IfaceExport = (ModuleName, [GenAvailInfo OccName]) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl add emptyNameSet avails @@ -595,26 +616,31 @@ pprAvail (Avail n) = ppr n \end{code} \begin{code} -type FixityEnv = NameEnv (FixitySig Name) - -- We keep the whole fixity sig so that we - -- can report line-number info when there is a duplicate - -- fixity declaration +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n `orElse` defaultFixity + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Fixity +emptyIfaceFixCache n = defaultFixity + +-- This fixity environment is for source code only +type FixityEnv = NameEnv FixItem + +-- We keep the OccName in the range so that we can generate an interface from it +data FixItem = FixItem OccName Fixity SrcLoc + +instance Outputable FixItem where + ppr (FixItem occ fix loc) = ppr fix <+> ppr occ <+> parens (ppr loc) emptyFixityEnv :: FixityEnv emptyFixityEnv = emptyNameEnv lookupFixity :: FixityEnv -> Name -> Fixity lookupFixity env n = case lookupNameEnv env n of - Just (FixitySig _ fix _) -> fix - Nothing -> defaultFixity - -collectFixities :: FixityEnv -> [TyClDecl Name] -> [FixitySig Name] --- Collect fixities for the specified declarations -collectFixities env decls - = [ fix - | d <- decls, (n,_) <- tyClDeclNames d, - Just fix <- [lookupNameEnv env n] - ] + Just (FixItem _ fix _) -> fix + Nothing -> defaultFixity \end{code} @@ -646,12 +672,13 @@ data Dependencies noDependencies :: Dependencies noDependencies = Deps [] [] [] -data Usage name - = Usage { usg_name :: ModuleName, -- Name of the module - usg_mod :: Version, -- Module version - usg_exports :: Maybe Version, -- Export-list version, if we depend on it - usg_entities :: [(name,Version)], -- Sorted by occurrence name - usg_rules :: Version -- Rules version +data Usage + = Usage { usg_name :: ModuleName, -- Name of the module + usg_mod :: Version, -- Module version + usg_entities :: [(OccName,Version)], -- Sorted by occurrence name + usg_exports :: Maybe Version, -- Export-list version, if we depend on it + usg_rules :: Version -- Orphan-rules version (for non-orphan + -- modules this will always be initialVersion) } deriving( Eq ) -- This type doesn't let you say "I imported f but none of the rules in -- the module". If you use anything in the module you get its rule version @@ -668,23 +695,10 @@ data Usage name %************************************************************************ %* * -\subsection{The persistent compiler state} + The External Package State %* * %************************************************************************ -The @PersistentCompilerState@ persists across successive calls to the -compiler. - -\begin{code} -data PersistentCompilerState - = PCS { - pcs_nc :: !NameCache, - pcs_EPS :: ExternalPackageState - -- non-strict because we fill it with error in HscMain - } -\end{code} - - \begin{code} type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase @@ -714,35 +728,26 @@ data ExternalPackageState -- Holding pens for stuff that has been read in from file, -- but not yet slurped into the renamer - eps_decls :: !DeclsMap, + eps_decls :: !DeclPool, -- A single, global map of Names to unslurped decls - eps_insts :: !IfaceInsts, - -- The as-yet un-slurped instance decls; this bag is depleted when we - -- slurp an instance decl so that we don't slurp the same one twice. - -- Each is 'gated' by the names that must be available before - -- this instance decl is needed. - eps_rules :: !IfaceRules, - -- Similar to instance decls, only for rules - - eps_inst_gates :: !NameSet -- Gates for instance decls - -- The instance gates must accumulate across - -- all invocations of the renamer; - -- see "the gating story" in RnIfaces.lhs - -- These names should all be from other packages; - -- for the home package we have all the instance - -- declarations anyhow + -- Decls move from here to eps_PTE + + eps_insts :: !InstPool, + -- The as-yet un-slurped instance decls + -- Decls move from here to eps_inst_env + -- Each instance is 'gated' by the names that must be + -- available before this instance decl is needed. + + eps_rules :: !RulePool + -- Rules move from here to eps_rule_base when + -- all their LHS free vars are in the eps_PTE + -- To maintain this invariant, we need to check the pool + -- a) when adding to the rule pool by loading an interface + -- (some of the new rules may alrady have all their + -- gates in the eps_PTE) + -- b) when extending the eps_PTE when we load a decl + -- from the eps_decls pool } - -emptyExternalPackageState = EPS { - eps_decls = (emptyNameEnv, 0), - eps_insts = (emptyBag, 0), - eps_inst_gates = emptyNameSet, - eps_rules = (emptyBag, 0), - eps_PIT = emptyPackageIfaceTable, - eps_PTE = emptyTypeEnv, - eps_inst_env = emptyInstEnv, - eps_rule_base = emptyRuleBase - } \end{code} The NameCache makes sure that there is just one Unique assigned for @@ -767,31 +772,43 @@ data NameCache -- Ensures that one implicit parameter name gets one unique } -type OrigNameCache = ModuleEnv (Module, OccNameCache) - -- Maps a module *name* to a Module, - -- plus the OccNameEnv fot that module -type OccNameCache = FiniteMap OccName Name - -- Maps the OccName to a Name - -- A FiniteMap because OccNames have a Namespace/Faststring pair - -type OrigIParamCache = FiniteMap (IPName RdrName) (IPName Name) +type OrigNameCache = ModuleEnv (OccEnv Name) +type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) \end{code} -A DeclsMap contains a binding for each Name in the declaration -including the constructors of a type decl etc. The Bool is True just -for the 'main' Name. - \begin{code} -type DeclsMap = (NameEnv (AvailInfo, Bool, (Module, TyClDecl RdrName)), Int) - -- The Int says how many have been sucked in - -type IfaceInsts = GatedDecls (InstDecl RdrName) -type IfaceRules = GatedDecls (RuleDecl RdrName) - -type GatedDecls d = (Bag (GatedDecl d), Int) -- The Int says how many have been sucked in -type GatedDecl d = (GateFn, (Module, d)) -type GateFn = (Name -> Bool) -> Bool -- Returns True <=> gate is open - -- The (Name -> Bool) fn returns True for visible Names +data Pool p = Pool (NameEnv p) -- The pool itself, indexed by some primary key + Int -- Number of decls slurped into the map + Int -- Number of decls slurped out of the map + +emptyPool = Pool emptyNameEnv 0 0 + +instance Outputable p => Outputable (Pool p) where + ppr (Pool p n_in n_out) -- Debug printing only + = vcat [ptext SLIT("Pool") <+> int n_in <+> int n_out, + nest 2 (ppr p)] + +type DeclPool = Pool IfaceDecl + +------------------------- +type Gated d = ([Name], (ModuleName, d)) -- The [Name] 'gate' the declaration + -- ModuleName records which iface file this + -- decl came from + +type RulePool = Pool [Gated IfaceRule] + +addRuleToPool :: NameEnv [Gated IfaceRule] + -> (ModuleName, IfaceRule) + -> [Name] -- Free vars of rule; always non-empty + -> NameEnv [Gated IfaceRule] +addRuleToPool rules rule (fv:fvs) = extendNameEnv_C combine rules fv [(fvs,rule)] + where + combine old _ = (fvs,rule) : old + +------------------------- +type InstPool = Pool [Gated IfaceInst] + -- The key of the Pool is the Class + -- The Names are the TyCons in the instance head -- For example, suppose this is in an interface file -- instance C T where ... -- We want to slurp this decl if both C and T are "visible" in @@ -861,156 +878,4 @@ byteCodeOfObject (BCOs bc) = bc \end{code} -%************************************************************************ -%* * -\subsection{Provenance and export info} -%* * -%************************************************************************ - -A LocalRdrEnv is used for local bindings (let, where, lambda, case) -Also used in - -\begin{code} -type LocalRdrEnv = RdrNameEnv Name - -extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnv env names - = addListToRdrEnv env [(mkRdrUnqual (nameOccName n), n) | n <- names] -\end{code} - -The GlobalRdrEnv gives maps RdrNames to Names. There is a separate -one for each module, corresponding to that module's top-level scope. - -\begin{code} -type GlobalRdrEnv = RdrNameEnv [GlobalRdrElt] - -- The list is because there may be name clashes - -- These only get reported on lookup, not on construction - -emptyGlobalRdrEnv = emptyRdrEnv - -data GlobalRdrElt - = GRE { gre_name :: Name, - gre_parent :: Maybe Name, -- Name of the "parent" structure, for - -- * the tycon of a data con - -- * the class of a class op - -- For others it's Nothing - -- Invariant: gre_name g /= gre_parent g - -- when the latter is a Just - - gre_prov :: Provenance, -- Why it's in scope - gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated - } - -instance Outputable GlobalRdrElt where - ppr gre = ppr (gre_name gre) <+> - parens (pp_parent (gre_parent gre) <+> pprNameProvenance gre) - where - pp_parent (Just p) = text "parent:" <+> ppr p <> comma - pp_parent Nothing = empty - -pprGlobalRdrEnv env - = vcat (map pp (rdrEnvToList env)) - where - pp (rn, gres) = ppr rn <> colon <+> - vcat [ ppr (gre_name gre) <+> pprNameProvenance gre - | gre <- gres] - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_prov = LocalDef}) = True -isLocalGRE other = False -\end{code} - -@unQualInScope@ returns a function that takes a @Name@ and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the @Name@'s provenance to guide whether or not to print the name qualified -in error messages. -\begin{code} -unQualInScope :: GlobalRdrEnv -> Name -> Bool --- True if 'f' is in scope, and has only one binding, --- and the thing it is bound to is the name we are looking for --- (i.e. false if A.f and B.f are both in scope as unqualified 'f') --- --- Also checks for built-in syntax, which is always 'in scope' --- --- This fn is only efficient if the shared --- partial application is used a lot. -unQualInScope env - = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n - where - unqual_names :: NameSet - unqual_names = foldRdrEnv add emptyNameSet env - add rdr_name [gre] unquals | isUnqual rdr_name = addOneToNameSet unquals (gre_name gre) - add _ _ unquals = unquals -\end{code} - -The "provenance" of something says how it came to be in scope. - -\begin{code} -data Provenance - = LocalDef -- Defined locally - - | NonLocalDef -- Defined non-locally - ImportReason - --- Just used for grouping error messages (in RnEnv.warnUnusedBinds) -instance Eq Provenance where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Eq ImportReason where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Ord Provenance where - compare LocalDef LocalDef = EQ - compare LocalDef (NonLocalDef _) = LT - compare (NonLocalDef _) LocalDef = GT - - compare (NonLocalDef reason1) (NonLocalDef reason2) - = compare reason1 reason2 - -instance Ord ImportReason where - compare ImplicitImport ImplicitImport = EQ - compare ImplicitImport (UserImport _ _ _) = LT - compare (UserImport _ _ _) ImplicitImport = GT - compare (UserImport m1 loc1 _) (UserImport m2 loc2 _) - = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) - - -data ImportReason - = UserImport Module SrcLoc Bool -- Imported from module M on line L - -- Note the M may well not be the defining module - -- for this thing! - -- The Bool is true iff the thing was named *explicitly* in the import spec, - -- rather than being imported as part of a group; e.g. - -- import B - -- import C( T(..) ) - -- Here, everything imported by B, and the constructors of T - -- are not named explicitly; only T is named explicitly. - -- This info is used when warning of unused names. - - | ImplicitImport -- Imported implicitly for some other reason -\end{code} - -\begin{code} -hasBetterProv :: Provenance -> Provenance -> Bool --- Choose --- a local thing over an imported thing --- a user-imported thing over a non-user-imported thing --- an explicitly-imported thing over an implicitly imported thing -hasBetterProv LocalDef _ = True -hasBetterProv (NonLocalDef (UserImport _ _ _ )) (NonLocalDef ImplicitImport) = True -hasBetterProv _ _ = False - -pprNameProvenance :: GlobalRdrElt -> SDoc -pprNameProvenance (GRE {gre_name = name, gre_prov = prov}) - = case prov of - LocalDef -> ptext SLIT("defined at") <+> ppr (nameSrcLoc name) - NonLocalDef why -> sep [ppr_reason why, - nest 2 (ppr_defn (nameSrcLoc name))] - -ppr_reason ImplicitImport = ptext SLIT("implicitly imported") -ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc - -ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("defined at") <+> ppr loc) - | otherwise = empty -\end{code} diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 1731fa54a8..535cbe41a5 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.133 2003/09/23 14:33:00 simonmar Exp $ +-- $Id: Main.hs,v 1.134 2003/10/09 11:58:57 simonpj Exp $ -- -- GHC Driver program -- @@ -332,9 +332,9 @@ doMake :: [String] -> IO () doMake [] = throwDyn (UsageError "no input files") doMake srcs = do dflags <- getDynFlags - state <- cmInit Batch - graph <- cmDepAnal state dflags srcs - (_, ok_flag, _) <- cmLoadModules state dflags graph + state <- cmInit Batch dflags + graph <- cmDepAnal state srcs + (_, ok_flag, _) <- cmLoadModules state graph when (failed ok_flag) (exitWith (ExitFailure 1)) return () diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs deleted file mode 100644 index 9f31e7019b..0000000000 --- a/ghc/compiler/main/MkIface.lhs +++ /dev/null @@ -1,870 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% - -\section[MkIface]{Print an interface for a module} - -\begin{code} -module MkIface ( - showIface, mkIface, mkUsageInfo, - pprIface, - ifaceTyThing, - ) where - -#include "HsVersions.h" - -import HsSyn -import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr ) -import HsTypes ( toHsTyVars ) -import TysPrim ( alphaTyVars ) -import BasicTypes ( NewOrData(..), Activation(..), FixitySig(..), - Version, initialVersion, bumpVersion - ) -import NewDemand ( isTopSig ) -import TcRnMonad -import TcRnTypes ( ImportAvails(..) ) -import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) -import HscTypes ( VersionInfo(..), ModIface(..), - ModGuts(..), ModGuts, - GhciMode(..), HscEnv(..), Dependencies(..), - FixityEnv, lookupFixity, collectFixities, - IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - TyThing(..), DFunId, - Avails, AvailInfo, GenAvailInfo(..), availName, - ExternalPackageState(..), - ParsedIface(..), Usage(..), - Deprecations(..), initialVersionInfo, - lookupVersion, lookupIfaceByModName - ) - -import CmdLineOpts -import Id ( idType, idInfo, isImplicitId, idCafInfo ) -import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks ) -import IdInfo -- Lots -import CoreSyn ( CoreRule(..), IdCoreRule ) -import CoreFVs ( ruleLhsFreeNames ) -import CoreUnfold ( neverUnfold, unfoldingTemplate ) -import Name ( getName, nameModule, nameModule_maybe, nameOccName, - nameIsLocalOrFrom, Name, NamedThing(..) ) -import NameEnv -import NameSet -import OccName ( OccName, pprOccName ) -import TyCon ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta, - isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon, - isSynTyCon, isAlgTyCon, isForeignTyCon, - getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity ) -import Class ( classExtraBigSig, classTyCon ) -import FieldLabel ( fieldLabelType ) -import TcType ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead, - mkSigmaTy, mkFunTys, mkTyConApp, mkTyVarTys ) -import SrcLoc ( noSrcLoc ) -import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, - ModLocation(..), mkSysModuleNameFS, - ModuleEnv, emptyModuleEnv, lookupModuleEnv, - extendModuleEnv_C, moduleEnvElts - ) -import Outputable -import DriverUtil ( createDirectoryHierarchy, directoryOf ) -import Util ( sortLt, dropList, seqList ) -import Binary ( getBinFileWithDict ) -import BinIface ( writeBinIface, v_IgnoreHiVersion ) -import ErrUtils ( dumpIfSet_dyn ) -import FiniteMap -import FastString - -import DATA_IOREF ( writeIORef ) -import Monad ( when ) -import Maybe ( catMaybes, isJust, isNothing ) -import Maybes ( orElse ) -import IO ( putStrLn ) -\end{code} - - -%************************************************************************ -%* * -\subsection{Print out the contents of a binary interface} -%* * -%************************************************************************ - -\begin{code} -showIface :: FilePath -> IO () -showIface filename = do - -- skip the version check; we don't want to worry about profiled vs. - -- non-profiled interfaces, for example. - writeIORef v_IgnoreHiVersion True - parsed_iface <- Binary.getBinFileWithDict filename - let ParsedIface{ - pi_mod=pi_mod, pi_pkg=pi_pkg, pi_vers=pi_vers, - pi_deps=pi_deps, - pi_orphan=pi_orphan, pi_usages=pi_usages, - pi_exports=pi_exports, pi_decls=pi_decls, - pi_fixity=pi_fixity, pi_insts=pi_insts, - pi_rules=pi_rules, pi_deprecs=pi_deprecs } = parsed_iface - putStrLn (showSDoc (vcat [ - text "__interface" <+> doubleQuotes (ppr pi_pkg) - <+> ppr pi_mod <+> ppr pi_vers - <+> (if pi_orphan then char '!' else empty) - <+> ptext SLIT("where"), - -- no instance Outputable (WhatsImported): - pprExports id (snd pi_exports), - pprDeps pi_deps, - pprUsages id pi_usages, - hsep (map ppr_fix pi_fixity) <> semi, - vcat (map ppr_inst pi_insts), - vcat (map ppr_decl pi_decls), - ppr pi_rules - -- no instance Outputable (Either): - -- ppr pi_deprecs - ])) - where - ppr_fix (FixitySig n f _) = ppr f <+> ppr n - ppr_inst i = ppr i <+> semi - ppr_decl (v,d) = int v <+> ppr d <> semi -\end{code} - -%************************************************************************ -%* * -\subsection{Completing an interface} -%* * -%************************************************************************ - -\begin{code} -mkIface :: HscEnv - -> ModLocation - -> Maybe ModIface -- The old interface, if we have it - -> ModGuts -- The compiled, tidied module - -> IO ModIface -- The new one, complete with decls and versions --- mkFinalIface --- a) completes the interface --- b) writes it out to a file if necessary - -mkIface hsc_env location maybe_old_iface - impl@ModGuts{ mg_module = this_mod, - mg_usages = usages, - mg_deps = deps, - mg_exports = exports, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = deprecs, - mg_insts = insts, - mg_rules = rules, - mg_types = types } - = do { -- Sort the exports to make them easier to compare for versions - let { my_exports = groupAvails this_mod exports ; - - iface_w_decls = ModIface { mi_module = this_mod, - mi_package = opt_InPackage, - mi_version = initialVersionInfo, - mi_deps = deps, - mi_usages = usages, - mi_exports = my_exports, - mi_decls = new_decls, - mi_orphan = orphan_mod, - mi_boot = False, - mi_fixities = fix_env, - mi_globals = Just rdr_env, - mi_deprecs = deprecs } } - - -- Add version information - ; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls - - -- Write the interface file, if necessary - ; when (must_write_hi_file maybe_diffs) $ do - createDirectoryHierarchy (directoryOf hi_file_path) - writeBinIface hi_file_path final_iface - - -- Debug printing - ; write_diffs dflags final_iface maybe_diffs - - ; orphan_mod `seq` - return final_iface } - - where - dflags = hsc_dflags hsc_env - ghci_mode = hsc_mode hsc_env - omit_pragmas = dopt Opt_OmitInterfacePragmas dflags - - must_write_hi_file Nothing = False - must_write_hi_file (Just _diffs) = ghci_mode /= Interactive - -- We must write a new .hi file if there are some changes - -- and we're not in interactive mode - -- maybe_diffs = 'Nothing' means that even the usages havn't changed, - -- so there's no need to write a new interface file. But even if - -- the usages have changed, the module version may not have. - - hi_file_path = ml_hi_file location - new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls - inst_dcls = map ifaceInstance insts - ty_cls_dcls = foldNameEnv (ifaceTyThing_acc omit_pragmas) [] types - rule_dcls = map ifaceRule rules - orphan_mod = isOrphanModule impl - -write_diffs :: DynFlags -> ModIface -> Maybe SDoc -> IO () -write_diffs dflags new_iface Nothing - = do when (dopt Opt_D_dump_hi_diffs dflags) (printDump (text "INTERFACE UNCHANGED")) - dumpIfSet_dyn dflags Opt_D_dump_hi "UNCHANGED FINAL INTERFACE" (pprIface new_iface) - -write_diffs dflags new_iface (Just sdoc_diffs) - = do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs - dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface) -\end{code} - -\begin{code} -isOrphanModule :: ModGuts -> Bool -isOrphanModule (ModGuts {mg_module = this_mod, mg_insts = insts, mg_rules = rules}) - = any orphan_inst insts || any orphan_rule rules - where - -- A rule is an orphan if the LHS mentions nothing defined locally - orphan_inst dfun_id = no_locals (tyClsNamesOfDFunHead (idType dfun_id)) - -- A instance is an orphan if its head mentions nothing defined locally - orphan_rule rule = no_locals (ruleLhsFreeNames rule) - - no_locals names = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names) -\end{code} - -Implicit Ids and class tycons aren't included in interface files, so -we miss them out of the accumulating parameter here. - -\begin{code} -ifaceTyThing_acc :: Bool -> TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] --- Don't put implicit things into the result -ifaceTyThing_acc omit_pragmas (ADataCon dc) so_far = so_far -ifaceTyThing_acc omit_pragmas (AnId id) so_far | isImplicitId id = so_far -ifaceTyThing_acc omit_pragmas (ATyCon id) so_far | isClassTyCon id = so_far -ifaceTyThing_acc omit_pragmas other so_far - = ifaceTyThing omit_pragmas other : so_far -\end{code} - -Convert *any* TyThing into a RenamedTyClDecl. Used both for -generating interface files and for the ':info' command in GHCi. - -\begin{code} -ifaceTyThing :: Bool -> TyThing -> RenamedTyClDecl -ifaceTyThing omit_pragmas (AClass clas) = cls_decl - where - cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta, - tcdName = getName clas, - tcdTyVars = toHsTyVars clas_tyvars, - tcdFDs = toHsFDs clas_fds, - tcdSigs = map toClassOpSig op_stuff, - tcdMeths = Nothing, - tcdLoc = noSrcLoc } - - (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas - tycon = classTyCon clas - data_con = head (tyConDataCons tycon) - - toClassOpSig (sel_id, def_meth) - = ASSERT(sel_tyvars == clas_tyvars) - ClassOpSig (getName sel_id) def_meth (toHsType op_ty) noSrcLoc - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id) - op_ty = tcFunResultTy rho_ty - -ifaceTyThing omit_pragmas (ATyCon tycon) = ty_decl - where - ty_decl | isSynTyCon tycon - = TySynonym { tcdName = getName tycon, - tcdTyVars = toHsTyVars tyvars, - tcdSynRhs = toHsType syn_ty, - tcdLoc = noSrcLoc } - - | isAlgTyCon tycon - = TyData { tcdND = new_or_data, - tcdCtxt = toHsContext (tyConTheta tycon), - tcdName = getName tycon, - tcdTyVars = toHsTyVars tyvars, - tcdCons = ifaceConDecls (tyConDataConDetails tycon), - tcdDerivs = Nothing, - tcdGeneric = Just (isJust (tyConGenInfo tycon)), - -- Just True <=> has generic stuff - tcdLoc = noSrcLoc } - - | isForeignTyCon tycon - = ForeignType { tcdName = getName tycon, - tcdExtName = Nothing, - tcdFoType = DNType, -- The only case at present - tcdLoc = noSrcLoc } - - | isPrimTyCon tycon || isFunTyCon tycon - -- needed in GHCi for ':info Int#', for example - = TyData { tcdND = DataType, - tcdCtxt = [], - tcdName = getName tycon, - tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars), - tcdCons = Unknown, - tcdDerivs = Nothing, - tcdGeneric = Just False, - tcdLoc = noSrcLoc } - - | otherwise = pprPanic "ifaceTyThing" (ppr tycon) - - tyvars = tyConTyVars tycon - (_, syn_ty) = getSynTyConDefn tycon - new_or_data | isNewTyCon tycon = NewType - | otherwise = DataType - - ifaceConDecls Unknown = Unknown - ifaceConDecls (HasCons n) = HasCons n - ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) - - ifaceConDecl data_con - = ConDecl (dataConName data_con) - (toHsTyVars ex_tyvars) - (toHsContext ex_theta) - details noSrcLoc - where - (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con - field_labels = dataConFieldLabels data_con - strict_marks = dropList ex_theta (dataConStrictMarks data_con) - -- The 'drop' is because dataConStrictMarks - -- includes the existential dictionaries - details | null field_labels - = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) - PrefixCon (zipWith BangType strict_marks (map toHsType arg_tys)) - - | otherwise - = RecCon (zipWith mk_field strict_marks field_labels) - - mk_field strict_mark field_label - = (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label))) - -ifaceTyThing omit_pragmas (AnId id) = iface_sig - where - iface_sig = IfaceSig { tcdName = getName id, - tcdType = toHsType id_type, - tcdIdInfo = hs_idinfo, - tcdLoc = noSrcLoc } - - id_type = idType id - id_info = idInfo id - arity_info = arityInfo id_info - caf_info = idCafInfo id - - hs_idinfo | omit_pragmas - = [] - | otherwise - = catMaybes [arity_hsinfo, caf_hsinfo, - strict_hsinfo, wrkr_hsinfo, - unfold_hsinfo] - - ------------ Arity -------------- - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of - Just sig | not (isTopSig sig) -> Just (HsStrictness sig) - _other -> Nothing - - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = case work_info of { HasWorker _ _ -> True; other -> False } - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker (getName work_id) wrap_arity) - NoWorker -> Nothing - - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - inline_prag = inlinePragInfo id_info - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing - | otherwise = Just (HsUnfold inline_prag (toUfExpr rhs)) - - -ifaceTyThing omit_pragmas (ADataCon dc) - -- This case only happens in the call to ifaceThing in InteractiveUI - -- Otherwise DataCons are filtered out in ifaceThing_acc - = IfaceSig { tcdName = getName dc, - tcdType = toHsType full_ty, - tcdIdInfo = [], - tcdLoc = noSrcLoc } - where - (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc - - -- The "stupid context" isn't part of the wrapper-Id type - -- (for better or worse -- see note in DataCon.lhs), so we - -- have to make it up here - full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) - (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs))) -\end{code} - -\begin{code} -ifaceInstance :: DFunId -> RenamedInstDecl -ifaceInstance dfun_id - = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc - where - tidy_ty = tidyTopType (deNoteType (idType dfun_id)) - -- The deNoteType is very important. It removes all type - -- synonyms from the instance type in interface files. - -- That in turn makes sure that when reading in instance decls - -- from interface files that the 'gating' mechanism works properly. - -- Otherwise you could have - -- type Tibble = T Int - -- instance Foo Tibble where ... - -- and this instance decl wouldn't get imported into a module - -- that mentioned T but not Tibble. - -ifaceRule :: IdCoreRule -> RuleDecl Name -ifaceRule (id, BuiltinRule _ _) - = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) - -ifaceRule (id, Rule name act bndrs args rhs) - = IfaceRule name act (map toUfBndr bndrs) (getName id) - (map toUfExpr args) (toUfExpr rhs) noSrcLoc - -bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name -bogusIfaceRule id - = IfaceRule FSLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc -\end{code} - - -%********************************************************* -%* * -\subsection{Keeping track of what we've slurped, and version numbers} -%* * -%********************************************************* - -mkUsageInfo figures out what the ``usage information'' for this -moudule is; that is, what it must record in its interface file as the -things it uses. - -We produce a line for every module B below the module, A, currently being -compiled: - import B <n> ; -to record the fact that A does import B indirectly. This is used to decide -to look to look for B.hi rather than B.hi-boot when compiling a module that -imports A. This line says that A imports B, but uses nothing in it. -So we'll get an early bale-out when compiling A if B's version changes. - -The usage information records: - -\begin{itemize} -\item (a) anything reachable from its body code -\item (b) any module exported with a @module Foo@ -\item (c) anything reachable from an exported item -\end{itemize} - -Why (b)? Because if @Foo@ changes then this module's export list -will change, so we must recompile this module at least as far as -making a new interface file --- but in practice that means complete -recompilation. - -Why (c)? Consider this: -\begin{verbatim} - module A( f, g ) where | module B( f ) where - import B( f ) | f = h 3 - g = ... | h = ... -\end{verbatim} - -Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in -@A@'s usages? Our idea is that we aren't going to touch A.hi if it is -*identical* to what it was before. If anything about @B.f@ changes -than anyone who imports @A@ should be recompiled in case they use -@B.f@ (they'll get an early exit if they don't). So, if anything -about @B.f@ changes we'd better make sure that something in A.hi -changes, and the convenient way to do that is to record the version -number @B.f@ in A.hi in the usage list. If B.f changes that'll force a -complete recompiation of A, which is overkill but it's the only way to -write a new, slightly different, A.hi. - -But the example is tricker. Even if @B.f@ doesn't change at all, -@B.h@ may do so, and this change may not be reflected in @f@'s version -number. But with -O, a module that imports A must be recompiled if -@B.h@ changes! So A must record a dependency on @B.h@. So we treat -the occurrence of @B.f@ in the export list *just as if* it were in the -code of A, and thereby haul in all the stuff reachable from it. - - *** Conclusion: if A mentions B.f in its export list, - behave just as if A mentioned B.f in its source code, - and slurp in B.f and all its transitive closure *** - -[NB: If B was compiled with -O, but A isn't, we should really *still* -haul in all the unfoldings for B, in case the module that imports A *is* -compiled with -O. I think this is the case.] - -\begin{code} -mkUsageInfo :: HscEnv -> ExternalPackageState - -> ImportAvails -> EntityUsage - -> [Usage Name] - -mkUsageInfo hsc_env eps - (ImportAvails { imp_mods = dir_imp_mods, - imp_dep_mods = dep_mods }) - used_names - = -- seq the list of Usages returned: occasionally these - -- don't get evaluated for a while and we can end up hanging on to - -- the entire collection of Ifaces. - usages `seqList` usages - where - usages = catMaybes [ mkUsage mod_name - | (mod_name,_) <- moduleEnvElts dep_mods] - -- ToDo: do we need to sort into canonical order? - - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - - import_all mod = case lookupModuleEnv dir_imp_mods mod of - Just (_, Nothing) -> True - _ -> False - - -- ent_map groups together all the things imported and used - -- from a particular module in this package - ent_map :: ModuleEnv [Name] - ent_map = foldNameSet add_mv emptyModuleEnv used_names - add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name] - where - mod = nameModule name - add_item names _ = name:names - - -- We want to create a Usage for a home module if - -- a) we used something from; has something in used_names - -- b) we imported all of it, even if we used nothing from it - -- (need to recompile if its export list changes: export_vers) - -- c) is a home-package orphan module (need to recompile if its - -- instance decls change: rules_vers) - mkUsage :: ModuleName -> Maybe (Usage Name) - mkUsage mod_name - | isNothing maybe_iface -- We can't depend on it if we didn't - || not (isHomeModule mod) -- even open the interface! - || (null used_names - && not all_imported - && not orphan_mod) - = Nothing -- Record no usage info - - | otherwise - = Just (Usage { usg_name = moduleName mod, - usg_mod = mod_vers, - usg_exports = export_vers, - usg_entities = ent_vers, - usg_rules = rules_vers }) - where - maybe_iface = lookupIfaceByModName hpt pit mod_name - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - Just iface = maybe_iface - mod = mi_module iface - version_info = mi_version iface - orphan_mod = mi_orphan iface - version_env = vers_decls version_info - mod_vers = vers_module version_info - rules_vers = vers_rules version_info - all_imported = import_all mod - export_vers | all_imported = Just (vers_exports version_info) - | otherwise = Nothing - - -- The sort is to put them into canonical order - used_names = lookupModuleEnv ent_map mod `orElse` [] - ent_vers = [(n, lookupVersion version_env n) - | n <- sortLt lt_occ used_names ] - lt_occ n1 n2 = nameOccName n1 < nameOccName n2 - -- ToDo: is '<' on OccNames the right thing; may differ between runs? -\end{code} - -\begin{code} -groupAvails :: Module -> Avails -> [(ModuleName, Avails)] - -- Group by module and sort by occurrence - -- This keeps the list in canonical order -groupAvails this_mod avails - = [ (mkSysModuleNameFS fs, sortLt lt avails) - | (fs,avails) <- fmToList groupFM - ] - where - groupFM :: FiniteMap FastString Avails - -- Deliberately use the FastString so we - -- get a canonical ordering - groupFM = foldl add emptyFM avails - - add env avail = addToFM_C combine env mod_fs [avail'] - where - mod_fs = moduleNameFS (moduleName avail_mod) - avail_mod = case nameModule_maybe (availName avail) of - Just m -> m - Nothing -> this_mod - combine old _ = avail':old - avail' = sortAvail avail - - a1 `lt` a2 = occ1 < occ2 - where - occ1 = nameOccName (availName a1) - occ2 = nameOccName (availName a2) - -sortAvail :: AvailInfo -> AvailInfo --- Sort the sub-names into canonical order. --- The canonical order has the "main name" at the beginning --- (if it's there at all) -sortAvail (Avail n) = Avail n -sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns)) - | otherwise = AvailTC n ( sortLt lt ns) - where - n1 `lt` n2 = nameOccName n1 < nameOccName n2 -\end{code} - -%************************************************************************ -%* * -\subsection{Checking if the new interface is up to date -%* * -%************************************************************************ - -\begin{code} -addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi - -> ModIface -- The new interface decls - -> (ModIface, Maybe SDoc) -- Nothing => no change; no need to write new Iface - -- Just mi => Here is the new interface to write - -- with correct version numbers - --- NB: the fixities, declarations, rules are all assumed --- to be sorted by increasing order of hsDeclName, so that --- we can compare for equality - -addVersionInfo Nothing new_iface --- No old interface, so definitely write a new one! - = (new_iface, Just (text "No old interface available")) - -addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, - mi_decls = old_decls, - mi_fixities = old_fixities, - mi_deprecs = old_deprecs })) - new_iface@(ModIface { mi_decls = new_decls, - mi_fixities = new_fixities, - mi_deprecs = new_deprecs }) - - | no_output_change && no_usage_change - = (new_iface, Nothing) - -- don't return the old iface because it may not have an - -- mi_globals field set to anything reasonable. - - | otherwise -- Add updated version numbers - = --pprTrace "completeIface" (ppr (dcl_tycl old_decls)) - (final_iface, Just pp_diffs) - - where - final_iface = new_iface { mi_version = new_version } - old_mod_vers = vers_module old_version - new_version = VersionInfo { vers_module = bumpVersion no_output_change old_mod_vers, - vers_exports = bumpVersion no_export_change (vers_exports old_version), - vers_rules = bumpVersion no_rule_change (vers_rules old_version), - vers_decls = tc_vers } - - no_output_change = no_tc_change && no_rule_change && no_export_change && no_deprec_change - no_usage_change = mi_usages old_iface == mi_usages new_iface - - no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted - no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto - && dcl_insts old_decls == dcl_insts new_decls - no_deprec_change = old_deprecs == new_deprecs - - -- Fill in the version number on the new declarations by looking at the old declarations. - -- Set the flag if anything changes. - -- Assumes that the decls are sorted by hsDeclName. - (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_version old_fixities new_fixities - (dcl_tycl old_decls) (dcl_tycl new_decls) - pp_diffs = vcat [pp_tc_diffs, - pp_change no_export_change "Export list", - pp_change no_rule_change "Rules", - pp_change no_deprec_change "Deprecations", - pp_change no_usage_change "Usages"] - pp_change True what = empty - pp_change False what = text what <+> ptext SLIT("changed") - -diffDecls :: VersionInfo -- Old version - -> FixityEnv -> FixityEnv -- Old and new fixities - -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls - -> (Bool, -- True <=> no change - SDoc, -- Record of differences - NameEnv Version) -- New version map - -diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers }) - old_fixities new_fixities old new - = diff True empty emptyNameEnv old new - where - -- When seeing if two decls are the same, - -- remember to check whether any relevant fixity has changed - eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1) - same_fixity n = lookupFixity old_fixities n == lookupFixity new_fixities n - - diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers) - diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods [] - diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers_with_new [] nds - where - new_vers_with_new = extendNameEnv new_vers (tyClDeclName nd) (bumpVersion False old_mod_vers) - -- When adding a new item, start from the old module version - -- This way, if you have version 4 of f, then delete f, then add f again, - -- you'll get version 6 of f, which will (correctly) force recompilation of - -- clients - - diff ok_so_far pp new_vers (od:ods) (nd:nds) - = case od_name `compare` nd_name of - LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds) - GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds - EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds - | otherwise -> diff False (pp $$ changed od nd) new_vers_with_diff ods nds - where - od_name = tyClDeclName od - nd_name = tyClDeclName nd - new_vers_with_diff = extendNameEnv new_vers nd_name (bumpVersion False old_version) - old_version = lookupVersion old_decls_vers od_name - - only_old d = ptext SLIT("Only in old iface:") <+> ppr d - only_new d = ptext SLIT("Only in new iface:") <+> ppr d - changed od nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr od) $$ - (ptext SLIT("New:") <+> ppr nd)) -\end{code} - - -b%************************************************************************ -%* * -\subsection{Writing an interface file} -%* * -%************************************************************************ - -\begin{code} -pprIface :: ModIface -> SDoc -pprIface iface - = vcat [ ptext SLIT("__interface") - <+> doubleQuotes (ftext (mi_package iface)) - <+> ppr (mi_module iface) <+> ppr (vers_module version_info) - <+> pp_sub_vers - <+> (if mi_orphan iface then char '!' else empty) - <+> int opt_HiVersion - <+> ptext SLIT("where") - - , pprExports nameOccName (mi_exports iface) - , pprDeps (mi_deps iface) - , pprUsages nameOccName (mi_usages iface) - - , pprFixities (mi_fixities iface) (dcl_tycl decls) - , pprIfaceDecls (vers_decls version_info) decls - , pprRulesAndDeprecs (dcl_rules decls) (mi_deprecs iface) - ] - where - version_info = mi_version iface - decls = mi_decls iface - exp_vers = vers_exports version_info - - rule_vers = vers_rules version_info - - pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty - | otherwise = brackets (ppr exp_vers <+> ppr rule_vers) -\end{code} - -When printing export lists, we print like this: - Avail f f - AvailTC C [C, x, y] C(x,y) - AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C - -\begin{code} -pprExports :: Eq a => (a -> OccName) -> [(ModuleName, [GenAvailInfo a])] -> SDoc -pprExports getOcc exports = vcat (map (pprExport getOcc) exports) - -pprExport :: Eq a => (a -> OccName) -> (ModuleName, [GenAvailInfo a]) -> SDoc -pprExport getOcc (mod, items) - = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi - where - --pp_avail :: GenAvailInfo a -> SDoc - pp_avail (Avail name) = ppr (getOcc name) - pp_avail (AvailTC _ []) = empty - pp_avail (AvailTC n (n':ns)) - | n==n' = ppr (getOcc n) <> pp_export ns - | otherwise = ppr (getOcc n) <> char '|' <> pp_export (n':ns) - - pp_export [] = empty - pp_export names = braces (hsep (map (ppr.getOcc) names)) - -pprOcc :: Name -> SDoc -- Print the occurrence name only -pprOcc n = pprOccName (nameOccName n) -\end{code} - - -\begin{code} -pprUsages :: (a -> OccName) -> [Usage a] -> SDoc -pprUsages getOcc usages = vcat (map (pprUsage getOcc) usages) - -pprUsage :: (a -> OccName) -> Usage a -> SDoc -pprUsage getOcc usage - = hsep [ptext SLIT("import"), ppr (usg_name usage), - int (usg_mod usage), - pp_export_version (usg_exports usage), - int (usg_rules usage), - pp_versions (usg_entities usage) - ] <> semi - where - pp_versions nvs = hsep [ ppr (getOcc n) <+> int v | (n,v) <- nvs ] - - pp_export_version Nothing = empty - pp_export_version (Just v) = int v - - -pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) - = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), - ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), - ptext SLIT("orphans:") <+> fsep (map ppr orphs) - ] - where - ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot - - ppr_boot True = text "[boot]" - ppr_boot False = empty -\end{code} - -\begin{code} -pprIfaceDecls :: NameEnv Int -> IfaceDecls -> SDoc -pprIfaceDecls version_map decls - = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls] - , vcat (map ppr_decl (dcl_tycl decls)) - ] - where - ppr_decl d = ppr_vers d <+> ppr d <> semi - - -- Print the version for the decl - ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of - Nothing -> empty - Just v -> int v -\end{code} - -\begin{code} -pprFixities :: FixityEnv - -> [TyClDecl Name] - -> SDoc -pprFixities fixity_map decls - = hsep [ ppr fix <+> ppr n - | FixitySig n fix _ <- collectFixities fixity_map decls ] <> semi - --- Disgusting to print these two together, but that's --- the way the interface parser currently expects them. -pprRulesAndDeprecs :: (Outputable a) => [a] -> Deprecations -> SDoc -pprRulesAndDeprecs [] NoDeprecs = empty -pprRulesAndDeprecs rules deprecs - = ptext SLIT("{-##") <+> (pp_rules rules $$ pp_deprecs deprecs) <+> ptext SLIT("##-}") - where - pp_rules [] = empty - pp_rules rules = ptext SLIT("__R") <+> vcat (map ppr rules) - - pp_deprecs NoDeprecs = empty - pp_deprecs deprecs = ptext SLIT("__D") <+> guts - where - guts = case deprecs of - DeprecAll txt -> doubleQuotes (ftext txt) - DeprecSome env -> ppr_deprec_env env - -ppr_deprec_env :: NameEnv (Name, FastString) -> SDoc -ppr_deprec_env env = vcat (punctuate semi (map pp_deprec (nameEnvElts env))) - where - pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ftext txt) -\end{code} diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index cfecbca2a6..abbbcea1eb 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -98,8 +98,8 @@ loadPackageConfig conf_filename = do buf <- hGetStringBuffer conf_filename let loc = mkSrcLoc (mkFastString conf_filename) 1 0 case unP parse (mkPState buf loc defaultDynFlags) of - PFailed l1 l2 err -> do - throwDyn (InstallationError (showPFailed l1 l2 err)) + PFailed l1 l2 err -> + throwDyn (InstallationError (showSDoc (showPFailed l1 l2 err))) POk _ pkg_details -> do return pkg_details diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 61b5b8ecc4..aaedea479b 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,7 +8,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) +import CmdLineOpts ( DynFlag(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) @@ -26,16 +26,15 @@ import Id ( idType, idInfo, idName, idCoreRules, import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( Arity, isNeverActive ) -import Name ( getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc +import Name ( Name, getOccName, nameOccName, mkInternalName, + localiseName, isExternalName, nameSrcLoc, nameParent_maybe ) -import RnEnv ( lookupOrigNameCache, newExternalName ) +import IfaceEnv ( allocateGlobalBinder ) import NameEnv ( lookupNameEnv, filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType ) import Module ( Module ) -import HscTypes ( PersistentCompilerState( pcs_nc ), - NameCache( nsNames, nsUniqs ), +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), TypeEnv, extendTypeEnvList, typeEnvIds, ModGuts(..), ModGuts, TyThing(..) ) @@ -44,9 +43,9 @@ import ErrUtils ( showPass, dumpIfSet_core ) import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) -import Util ( mapAccumL ) import Maybe ( isJust ) import Outputable +import DATA_IOREF ( IORef, readIORef, writeIORef ) import FastTypes hiding ( fastOr ) \end{code} @@ -86,7 +85,7 @@ binder [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.] - We use the NameCache kept in the PersistentCompilerState as the + We use the NameCache kept in the HscEnv as the source of such system-wide uniques. For external Ids, use the original-name cache in the NameCache @@ -118,16 +117,15 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -tidyCorePgm :: DynFlags - -> PersistentCompilerState - -> ModGuts - -> IO (PersistentCompilerState, ModGuts) +tidyCorePgm :: HscEnv -> ModGuts -> IO ModGuts -tidyCorePgm dflags pcs +tidyCorePgm hsc_env mod_impl@(ModGuts { mg_module = mod, mg_types = env_tc, mg_insts = insts_tc, mg_binds = binds_in, mg_rules = orphans_in }) - = do { showPass dflags "Tidy Core" + = do { let { dflags = hsc_dflags hsc_env + ; nc_var = hsc_NC hsc_env } + ; showPass dflags "Tidy Core" ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_in @@ -146,9 +144,8 @@ tidyCorePgm dflags pcs -- The second exported decl must 'get' the name 'f', so we -- have to put 'f' in the avoids list before we get to the first -- decl. tidyTopId then does a no-op on exported binders. - ; let orig_ns = pcs_nc pcs - init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName name | bndr <- typeEnvIds env_tc, + ; let init_env = (initTidyOccEnv avoids, emptyVarEnv) + avoids = [getOccName name | bndr <- typeEnvIds env_tc, let name = idName bndr, isExternalName name] -- In computing our "avoids" list, we must include @@ -158,13 +155,10 @@ tidyCorePgm dflags pcs -- since their names are "taken". -- The type environment is a convenient source of such things. - ; let ((orig_ns', occ_env, subst_env), tidy_binds) - = mapAccumL (tidyTopBind mod ext_ids) - init_tidy_env binds_in + ; (final_env, tidy_binds) + <- tidyTopBinds mod nc_var ext_ids init_env binds_in - ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules - - ; let pcs' = pcs { pcs_nc = orig_ns' } + ; let tidy_rules = tidyIdRules final_env ext_rules ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds @@ -173,7 +167,8 @@ tidyCorePgm dflags pcs -- to lookup the id in the TypeEnv too, because -- those Ids have had their IdInfo stripped if -- necessary. - ; let lookup_dfun_id id = + ; let (_, subst_env ) = final_env + lookup_dfun_id id = case lookupVarEnv subst_env id of Nothing -> dfun_panic Just id -> @@ -195,7 +190,7 @@ tidyCorePgm dflags pcs "Tidy Core Rules" (pprIdRules tidy_rules) - ; return (pcs', tidy_result) + ; return tidy_result } tidyCoreExpr :: CoreExpr -> IO CoreExpr @@ -220,7 +215,7 @@ mkFinalTypeEnv :: Bool -- Omit interface pragmas -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings --- From (c) we keep only those Ids with Global names; +-- From (c) we keep only those Ids with External names; -- the CoreTidy pass makes sure these are all and only -- the externally-accessible ones -- This truncates the type environment to include only the @@ -397,10 +392,8 @@ addExternal omit_iface_prags (id,rhs) needed \begin{code} -type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) - -- TopTidyEnv: when tidying we need to know --- * ns: The NameCache, containing a unique supply and any pre-ordained Names. +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. -- These may have arisen because the -- renamer read in an interface file mentioning M.$wf, say, -- and assigned it unique r77. If, on this compilation, we've @@ -412,91 +405,151 @@ type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -\end{code} +tidyTopBinds :: Module + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too + -> TidyEnv -> [CoreBind] + -> IO (TidyEnv, [CoreBind]) +tidyTopBinds mod nc_var ext_ids tidy_env [] + = return (tidy_env, []) -\begin{code} +tidyTopBinds mod nc_var ext_ids tidy_env (b:bs) + = do { (tidy_env1, b') <- tidyTopBind mod nc_var ext_ids tidy_env b + ; (tidy_env2, bs') <- tidyTopBinds mod nc_var ext_ids tidy_env1 bs + ; return (tidy_env2, b':bs') } + +------------------------ tidyTopBind :: Module - -> IdEnv Bool -- Domain = Ids that should be external + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> TopTidyEnv -> CoreBind - -> (TopTidyEnv, CoreBind) - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs) - = ((orig,occ,subst) , NonRec bndr' rhs') + -> TidyEnv -> CoreBind + -> IO (TidyEnv, CoreBind) + +tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) + = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr + ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs) + ; subst2 = extendVarEnv subst1 bndr bndr' + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, NonRec bndr' rhs') } where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - rec_tidy_env = (occ,subst) - rhs' = tidyExpr rec_tidy_env rhs - caf_info = hasCafRefs subst1 (idArity bndr') rhs' - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs) - = (final_env, Rec prs') + caf_info = hasCafRefs subst1 (idArity bndr) rhs + +tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) + = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs + ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info) + names' prs + ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, Rec prs') } where - (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs - rec_tidy_env = (occ,subst) - - do_one top_tidy_env (bndr,rhs) - = ((orig,occ,subst), (bndr',rhs')) - where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - - rhs' = tidyExpr rec_tidy_env rhs + bndrs = map fst prs -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info | or [ mayHaveCafRefs (hasCafRefs subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - -tidyTopBinder :: Module -> IdEnv Bool -> CafInfo - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -> CoreExpr -- RHS *before* tidying - -> CoreExpr -- RHS *after* tidying - -- The TidyEnv and the after-tidying RHS are - -- both are knot-tied: don't look at them! - -> TopTidyEnv -> Id -> (TopTidyEnv, Id) - -- NB: tidyTopBinder doesn't affect the unique supply - -tidyTopBinder mod ext_ids caf_info rec_tidy_env rhs tidy_rhs - env@(ns2, occ_env2, subst_env2) id + | otherwise = NoCafRefs + +-------------------------------------------------------------------- +-- tidyTopName +-- This is where we set names to local/global based on whether they really are +-- externally visible (see comment at the top of this module). If the name +-- was previously local, we have to give it a unique occurrence name if +-- we intend to externalise it. +tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, []) +tidyTopNames mod nc_var ext_ids occ_env (id:ids) + = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id + ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids + ; return (occ_env2, name:names) } + +tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var ext_ids occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { nc <- readIORef nc_var + ; let (nc', new_local_name) = mk_new_local nc + ; writeIORef nc_var nc' + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { nc <- readIORef nc_var + ; let (nc', new_external_name) = mk_new_external nc + ; writeIORef nc_var nc' + ; return (occ_env', new_external_name) } + where + name = idName id + external = id `elemVarEnv` ext_ids + global = isExternalName name + local = not global + internal = not external + mb_parent = nameParent_maybe name + loc = nameSrcLoc name + + (occ_env', occ') = tidyOccName occ_env (nameOccName name) + + mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc) + where + (us1, us2) = splitUniqSupply (nsUniqs nc) + uniq = uniqFromSupply us1 + + mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we want to + -- use the same name for externally-visible things as we did before. + + +----------------------------------------------------------- +tidyTopPair :: VarEnv Bool + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) -- This function is the heart of Step 2 -- The rec_tidy_env is the one to use for the IdInfo -- It's necessary because when we are dealing with a recursive -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group - -- The rhs is already tidied - - = ASSERT(isLocalId id) -- "all Ids defined in this module are local - -- until the CoreTidy phase" --GHC comentary - ((orig_env', occ_env', subst_env'), id') +tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) + = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local + -- until the CoreTidy phase" --GHC comentary + (bndr', rhs') where - (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2 - is_external - (idName id) - ty' = tidyTopType (idType id) - idinfo = tidyTopIdInfo rec_tidy_env is_external - (idInfo id) unfold_info arity - caf_info - - id' = mkVanillaGlobal name' ty' idinfo - - subst_env' = extendVarEnv subst_env2 id id' - - maybe_external = lookupVarEnv ext_ids id - is_external = isJust maybe_external + bndr' = mkVanillaGlobal name' ty' idinfo' + ty' = tidyTopType (idType bndr) + rhs' = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external) + (idInfo bndr) unfold_info arity + caf_info -- Expose an unfolding if ext_ids tells us to -- Remember that ext_ids maps an Id to a Bool: -- True to show the unfolding, False to hide it + maybe_external = lookupVarEnv ext_ids bndr show_unfold = maybe_external `orElse` False - unfold_info | show_unfold = mkTopUnfolding tidy_rhs + unfold_info | show_unfold = mkTopUnfolding rhs' | otherwise = noUnfolding -- Usually the Id will have an accurate arity on it, because @@ -542,50 +595,6 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info -- They have already been extracted by findExternalRules --- This is where we set names to local/global based on whether they really are --- externally visible (see comment at the top of this module). If the name --- was previously local, we have to give it a unique occurrence name if --- we intend to externalise it. -tidyTopName mod ns occ_env external name - | global && internal = (ns, occ_env, localiseName name) - - | global && external = (ns, occ_env, name) - -- Global names are assumed to have been allocated by the renamer, - -- so they already have the "right" unique - -- And it's a system-wide unique too - - | local && internal = (ns_w_local, occ_env', new_local_name) - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table - - | local && external = case lookupOrigNameCache ns_names mod occ' of - Just orig -> (ns, occ_env', orig) - Nothing -> (ns_w_global, occ_env', new_external_name) - -- If we want to externalise a currently-local name, check - -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table (ns_w_global). - -- This is needed when *re*-compiling a module in GHCi; we want to - -- use the same name for externally-visible things as we did before. - - where - global = isExternalName name - local = not global - internal = not external - loc = nameSrcLoc name - - (occ_env', occ') = tidyOccName occ_env (nameOccName name) - - ns_names = nsNames ns - (us1, us2) = splitUniqSupply (nsUniqs ns) - uniq = uniqFromSupply us1 - new_local_name = mkInternalName uniq occ' loc - ns_w_local = ns { nsUniqs = us2 } - - (ns_w_global, new_external_name) = newExternalName ns mod occ' loc - ------------ Worker -------------- tidyWorker tidy_env (HasWorker work_id wrap_arity) |