From: simonpj Date: Thu, 9 Oct 2003 13:11:31 +0000 (+0000) Subject: [project @ 2003-10-09 13:11:30 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~384 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=576650d4966549866ad2d07d618f99c9a0c7529d;p=ghc-hetmet.git [project @ 2003-10-09 13:11:30 by simonpj] Oops; forgot to add this entire directory! --- diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs new file mode 100644 index 0000000..255b86a --- /dev/null +++ b/ghc/compiler/iface/BinIface.hs @@ -0,0 +1,1005 @@ +{-% 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 IfaceSyn +import VarEnv +import TyCon ( DataConDetails(..) ) +import Class ( DefMeth(..) ) +import CostCentre +import Module ( moduleName, mkModule ) +import OccName ( OccName ) +import DriverState ( v_Build_tag ) +import CmdLineOpts ( opt_HiVersion ) +import Panic +import Binary +import Util + +import DATA_IOREF +import EXCEPTION ( throwDyn ) +import Monad ( when ) +import Outputable + +#include "HsVersions.h" + +-- --------------------------------------------------------------------------- +writeBinIface :: FilePath -> ModIface -> IO () +writeBinIface hi_path mod_iface + = putBinFileWithDict hi_path mod_iface + +readBinIface :: FilePath -> IO ModIface +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 !-} + +-- NewDemand +{-! for Demand derive: Binary !-} +{-! for Demands derive: Binary !-} +{-! for DmdResult derive: Binary !-} +{-! for StrictSig derive: Binary !-} + +-- TyCon +{-! for DataConDetails derive: Binary !-} + +-- Class +{-! for DefMeth derive: Binary !-} + +-- HsTypes +{-! for HsPred derive: Binary !-} +{-! for HsType derive: Binary !-} +{-! for TupCon 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 !-} + +-- CostCentre +{-! for IsCafCC derive: Binary !-} +{-! for IsDupdCC derive: Binary !-} +{-! for CostCentre derive: Binary !-} + + + +-- --------------------------------------------------------------------------- +-- Reading a binary interface into ParsedIface + +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_mod_vers = mod_vers, + mi_package = pkg_name, + mi_orphan = orphan, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_vers = exp_vers, + mi_fixities = fixities, + mi_deprecs = deprecs, + mi_decls = decls, + mi_insts = insts, + mi_rules = rules, + mi_rule_vers = rule_vers }) = do + build_tag <- readIORef v_Build_tag + put_ bh (show opt_HiVersion ++ build_tag) + put_ bh pkg_name + put_ bh (moduleName mod) + put_ bh mod_vers + put_ bh orphan + lazyPut bh deps + lazyPut bh usages + put_ bh exports + put_ bh exp_vers + put_ bh fixities + lazyPut bh deprecs + put_ bh decls + put_ bh insts + lazyPut bh rules + put_ bh rule_vers + + 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)) + + pkg_name <- get bh + mod_name <- get bh + + mod_vers <- get bh + orphan <- get bh + deps <- lazyGet bh + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_vers <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + rule_vers <- get bh + return (ModIface { + mi_package = pkg_name, + mi_module = mkModule pkg_name mod_name, + -- We write the module as a ModuleName, becuase whether + -- or not it's a home-package module depends on the importer + -- mkModule reconstructs the Module, by comparing the static + -- opt_InPackage flag with the package name in the interface file + mi_mod_vers = mod_vers, + mi_boot = False, -- Binary interfaces are never .hi-boot files! + mi_orphan = orphan, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_vers = exp_vers, + mi_fixities = fixities, + mi_deprecs = deprecs, + mi_decls = decls, + mi_insts = insts, + mi_rules = rules, + mi_rule_vers = rule_vers, + -- And build the cached values + mi_dep_fn = mkIfaceDepCache deprecs, + mi_fix_fn = mkIfaceFixCache fixities, + mi_ver_fn = mkIfaceVerCache decls }) + +GLOBAL_VAR(v_IgnoreHiVersion, False, Bool) + +------------------------------------------------------------------------- +-- Types from: HscTypes +------------------------------------------------------------------------- + +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 Usage 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 a => Binary (Deprecs a) where + put_ bh NoDeprecs = putByte bh 0 + put_ bh (DeprecAll t) = do + putByte bh 1 + put_ bh t + put_ bh (DeprecSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoDeprecs + 1 -> do aa <- get bh + return (DeprecAll aa) + _ -> do aa <- get bh + return (DeprecSome aa) + +------------------------------------------------------------------------- +-- Types from: BasicTypes +------------------------------------------------------------------------- + +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 MarkedStrict = do + putByte bh 0 + put_ bh MarkedUnboxed = do + putByte bh 1 + put_ bh NotMarkedStrict = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return MarkedStrict + 1 -> 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 TupCon where + put_ bh (TupCon ab ac) = do + put_ bh ab + put_ bh ac + get bh = do + ab <- get bh + ac <- get bh + return (TupCon ab ac) + +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 RecFlag where + put_ bh Recursive = do + putByte bh 0 + put_ bh NonRecursive = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return Recursive + _ -> do return NonRecursive + +instance Binary DefMeth where + put_ bh NoDefMeth = putByte bh 0 + put_ bh DefMeth = putByte bh 1 + put_ bh GenDefMeth = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return NoDefMeth + 1 -> return DefMeth + _ -> return GenDefMeth + +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 (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) + +------------------------------------------------------------------------- +-- Types from: Demand +------------------------------------------------------------------------- + +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) + +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) + + +------------------------------------------------------------------------- +-- Types from: CostCentre +------------------------------------------------------------------------- + +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) + +------------------------------------------------------------------------- +-- IfaceTypes and friends +------------------------------------------------------------------------- + +instance Binary IfaceExtName where + put_ bh (ExtPkg mod occ) = do + putByte bh 0 + put_ bh mod + put_ bh occ + put_ bh (HomePkg mod occ vers) = do + putByte bh 1 + put_ bh mod + put_ bh occ + put_ bh vers + put_ bh (LocalTop occ) = do + putByte bh 2 + put_ bh occ + put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop + putByte bh 2 + put_ bh occ + + get bh = do + h <- getByte bh + case h of + 0 -> do mod <- get bh + occ <- get bh + return (ExtPkg mod occ) + 1 -> do mod <- get bh + occ <- get bh + vers <- get bh + return (HomePkg mod occ vers) + _ -> do occ <- get bh + return (LocalTop occ) + +instance Binary IfaceBndr where + put_ bh (IfaceIdBndr aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceTvBndr ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceIdBndr aa) + _ -> do ab <- get bh + return (IfaceTvBndr ab) + +instance Binary IfaceKind where + put_ bh IfaceLiftedTypeKind = putByte bh 0 + put_ bh IfaceUnliftedTypeKind = putByte bh 1 + put_ bh IfaceOpenTypeKind = putByte bh 2 + put_ bh (IfaceFunKind k1 k2) = do + putByte bh 3 + put_ bh k1 + put_ bh k2 + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceLiftedTypeKind + 1 -> return IfaceUnliftedTypeKind + 2 -> return IfaceOpenTypeKind + _ -> do k1 <- get bh + k2 <- get bh + return (IfaceFunKind k1 k2) + +instance Binary IfaceType where + put_ bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad + put_ bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af + put_ bh (IfaceFunTy ag ah) = do + putByte bh 3 + put_ bh ag + put_ bh ah + put_ bh (IfacePredTy aq) = do + putByte bh 5 + put_ bh aq + + -- Simple compression for common cases of TyConApp + put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6 + put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7 + put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8 + put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty } + -- Unit tuple and pairs + put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10 + put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 } + -- Generic cases + put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys } + put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys } + + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + return (IfaceForAllTy aa ab) + 1 -> do ad <- get bh + return (IfaceTyVar ad) + 2 -> do ae <- get bh + af <- get bh + return (IfaceAppTy ae af) + 3 -> do ag <- get bh + ah <- get bh + return (IfaceFunTy ag ah) + 5 -> do ap <- get bh + return (IfacePredTy ap) + + -- Now the special cases for TyConApp + 6 -> return (IfaceTyConApp IfaceIntTc []) + 7 -> return (IfaceTyConApp IfaceCharTc []) + 8 -> return (IfaceTyConApp IfaceBoolTc []) + 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) } + 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) []) + 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) } + 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } + _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + +instance Binary IfaceTyCon where + -- Int,Char,Bool can't show up here because they can't not be saturated + put_ bh IfaceListTc = putByte bh 1 + put_ bh IfacePArrTc = putByte bh 2 + put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar } + put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance + + get bh = do + h <- getByte bh + case h of + 1 -> return IfaceListTc + 2 -> return IfacePArrTc + _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } + +instance Binary IfacePredType where + put_ bh (IfaceClassP aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceIParam 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 (IfaceClassP aa ab) + _ -> do ac <- get bh + ad <- get bh + return (IfaceIParam ac ad) + +------------------------------------------------------------------------- +-- IfaceExpr and friends +------------------------------------------------------------------------- + +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 2 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam ae af) = do + putByte bh 3 + put_ bh ae + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 4 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 5 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 6 + put_ bh al + put_ bh am + put_ bh (IfaceNote an ao) = do + putByte bh 7 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 8 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 9 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 10 + put_ bh aa + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 3 -> do ae <- get bh + af <- get bh + return (IfaceLam ae af) + 4 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 5 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 6 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 7 -> do an <- get bh + ao <- get bh + return (IfaceNote an ao) + 8 -> do ap <- get bh + return (IfaceLit ap) + 9 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + _ -> do aa <- get bh + return (IfaceExt aa) + +instance Binary IfaceConAlt where + put_ bh IfaceDefault = do + putByte bh 0 + put_ bh (IfaceDataAlt aa) = do + putByte bh 1 + put_ bh aa + put_ bh (IfaceTupleAlt ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceLitAlt ac) = do + putByte bh 3 + put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do return IfaceDefault + 1 -> do aa <- get bh + return (IfaceDataAlt aa) + 2 -> do ab <- get bh + return (IfaceTupleAlt ab) + _ -> do ac <- get bh + return (IfaceLitAlt ac) + +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceRec 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 (IfaceNonRec aa ab) + _ -> do ac <- get bh + return (IfaceRec ac) + +instance Binary IfaceIdInfo where + put_ bh NoInfo = putByte bh 0 + put_ bh (HasInfo i) = do + putByte bh 1 + lazyPut bh i + put_ bh DiscardedInfo = panic "BinIface:DiscardedInfo" + + get bh = do + h <- getByte bh + case h of + 0 -> return NoInfo + _ -> do info <- lazyGet bh + return (HasInfo info) + +instance Binary IfaceInfoItem 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 IfaceNote where + put_ bh (IfaceSCC aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceCoerce ab) = do + putByte bh 1 + put_ bh ab + put_ bh IfaceInlineCall = do + putByte bh 2 + put_ bh IfaceInlineMe = do + putByte bh 3 + put_ bh (IfaceCoreNote s) = do + putByte bh 4 + put_ bh s + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceSCC aa) + 1 -> do ab <- get bh + return (IfaceCoerce ab) + 2 -> do return IfaceInlineCall + 3 -> do return IfaceInlineMe + _ -> do ac <- get bh + return (IfaceCoreNote ac) + + +------------------------------------------------------------------------- +-- IfaceDecl and friends +------------------------------------------------------------------------- + +instance Binary IfaceDecl where + put_ bh (IfaceId name ty idinfo) = do + putByte bh 0 + put_ bh name + put_ bh ty + put_ bh idinfo + put_ bh (IfaceForeign ae af) = + error "Binary.put_(IfaceDecl): IfaceForeign" + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do + putByte bh 2 + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + + put_ bh (IfaceSyn aq ar as at) = do + putByte bh 3 + put_ bh aq + put_ bh ar + put_ bh as + put_ bh at + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do + putByte bh 4 + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ty <- get bh + idinfo <- get bh + return (IfaceId name ty idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) + 3 -> do + aq <- get bh + ar <- get bh + as <- get bh + at <- get bh + return (IfaceSyn aq ar as at) + _ -> do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + return (IfaceClass a1 a2 a3 a4 a5 a6 a7) + +instance Binary IfaceInst where + put_ bh (IfaceInst ty dfun) = do + put_ bh ty + put_ bh dfun + get bh = do ty <- get bh + dfun <- get bh + return (IfaceInst ty dfun) + +instance Binary IfaceConDecl where + put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + return (IfaceConDecl a1 a2 a3 a4 a5 a6) + +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp 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 (IfaceClassOp n def ty) + +instance Binary IfaceRule where + -- IfaceBuiltinRule should not happen here + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6) + +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 + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (DataCons aa) + _ -> do return Unknown + diff --git a/ghc/compiler/iface/BuildTyCl.lhs b/ghc/compiler/iface/BuildTyCl.lhs new file mode 100644 index 0000000..36fa37c --- /dev/null +++ b/ghc/compiler/iface/BuildTyCl.lhs @@ -0,0 +1,237 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +\begin{code} +module BuildTyCl ( + buildSynTyCon, buildAlgTyCon, buildDataCon, + buildClass, + newTyConRhs -- Just a useful little function with no obvious home + ) where + +#include "HsVersions.h" + +import IfaceEnv ( newImplicitBinder ) +import TcRnMonad + +import Subst ( substTyWith ) +import Util ( zipLazy ) +import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName ) +import VarSet +import DataCon ( DataCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels ) +import Var ( tyVarKind, TyVar ) +import TysWiredIn ( unitTy ) +import BasicTypes ( RecFlag, NewOrData( ..), StrictnessMark(..) ) +import Name ( Name ) +import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, + mkClassDataConOcc, mkSuperDictSelOcc ) +import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId ) +import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) +import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, + tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), + ArgVrcs, DataConDetails( ..), AlgTyConFlavour(..) ) +import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind, + tyVarsOfPred, splitTyConApp_maybe, mkPredTys, ThetaType, Type ) +import Outputable +import List ( nubBy ) + +\end{code} + + +\begin{code} +------------------------------------------------------ +buildSynTyCon name tvs rhs_ty arg_vrcs + = mkSynTyCon name kind tvs rhs_ty arg_vrcs + where + kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty) + + +------------------------------------------------------ +buildAlgTyCon :: NewOrData -> Name -> [TyVar] -> ThetaType + -> DataConDetails DataCon + -> ArgVrcs -> RecFlag + -> Bool -- True <=> want generics functions + -> TcRnIf m n TyCon + +buildAlgTyCon new_or_data tc_name tvs ctxt cons arg_vrcs is_rec want_generics + = do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs + cons sel_ids flavour is_rec want_generics + ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind + ; sel_ids = mkRecordSelectors tycon cons + ; flavour = case new_or_data of + NewType -> NewTyCon (mkNewTyConRep tycon) + DataType -> DataTyCon (all_nullary cons) + } + ; return tycon } + where + all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons + all_nullary Unknown = False -- Safe choice for unknown data types + -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon + -- but that looks at the *representation* arity, and isEnumerationType + -- refers to the *source* code definition + +------------------------------------------------------ +buildDataCon :: Name + -> [StrictnessMark] + -> [Name] -- Field labels + -> [TyVar] -> ThetaType + -> [TyVar] -> ThetaType + -> [Type] -> TyCon + -> TcRnIf m n DataCon +-- A wrapper for DataCon.mkDataCon that +-- a) makes the worker Id +-- b) makes the wrapper Id if necessary, including +-- allocating its unique (hence monadic) +buildDataCon src_name arg_stricts field_lbl_names + tyvars ctxt ex_tyvars ex_ctxt + arg_tys tycon + = newImplicitBinder src_name mkDataConWrapperOcc `thenM` \ wrap_name -> + newImplicitBinder src_name mkDataConWorkerOcc `thenM` \ work_name -> + -- This last one takes the name of the data constructor in the source + -- code, which (for Haskell source anyway) will be in the SrcDataName name + -- space, and makes it into a "real data constructor name" + let + -- Make the FieldLabels + -- The zipLazy avoids forcing the arg_tys too early + final_lbls = [ mkFieldLabel name tycon ty tag + | ((name, tag), ty) <- (field_lbl_names `zip` allFieldLabelTags) + `zipLazy` arg_tys + ] + + ctxt' = thinContext arg_tys ctxt + data_con = mkDataCon src_name arg_stricts final_lbls + tyvars ctxt' + ex_tyvars ex_ctxt + arg_tys tycon dc_ids + dc_ids = mkDataConIds wrap_name work_name data_con + in + returnM data_con + +-- The context for a data constructor should be limited to +-- the type variables mentioned in the arg_tys +thinContext arg_tys ctxt + = filter in_arg_tys ctxt + where + arg_tyvars = tyVarsOfTypes arg_tys + in_arg_tys pred = not $ isEmptyVarSet $ + tyVarsOfPred pred `intersectVarSet` arg_tyvars + +------------------------------------------------------ +mkRecordSelectors tycon data_cons + = -- We'll check later that fields with the same name + -- from different constructors have the same type. + [ mkRecordSelId tycon field + | field <- nubBy eq_name fields ] + where + fields = [ field | con <- visibleDataCons data_cons, + field <- dataConFieldLabels con ] + eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2 + + +------------------------------------------------------ +newTyConRhs :: TyCon -> Type -- The defn of a newtype, as written by the programmer +newTyConRhs tc = head (dataConOrigArgTys (head (tyConDataCons tc))) + +mkNewTyConRep :: TyCon -- The original type constructor + -> Type -- Chosen representation type + -- (guaranteed not to be another newtype) + +-- Find the representation type for this newtype TyCon +-- Remember that the representation type is the ultimate representation +-- type, looking through other newtypes. +-- +-- The non-recursive newtypes are easy, because they look transparent +-- to splitTyConApp_maybe, but recursive ones really are represented as +-- TyConApps (see TypeRep). +-- +-- The trick is to to deal correctly with recursive newtypes +-- such as newtype T = MkT T + +mkNewTyConRep tc + | null (tyConDataCons tc) = unitTy + -- External Core programs can have newtypes with no data constructors + | otherwise = go [] tc + where + -- Invariant: tc is a NewTyCon + -- tcs have been seen before + go tcs tc + | tc `elem` tcs = unitTy + | otherwise + = case splitTyConApp_maybe rep_ty of + Nothing -> rep_ty + Just (tc', tys) | not (isNewTyCon tc') -> rep_ty + | otherwise -> go1 (tc:tcs) tc' tys + where + rep_ty = newTyConRhs tc + + go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc) +\end{code} + + +\begin{code} +buildClass :: Name -> [TyVar] -> ThetaType + -> [FunDep TyVar] -- Functional dependencies + -> [(Name, DefMeth, Type)] -- Method info + -> RecFlag -> ArgVrcs -- Info for type constructor + -> TcRnIf m n Class + +buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs + = do { tycon_name <- newImplicitBinder class_name mkClassTyConOcc + ; datacon_name <- newImplicitBinder class_name mkClassDataConOcc + -- The class name is the 'parent' for this datacon, not its tycon, + -- because one should import the class to get the binding for + -- the datacon + ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) + [1..length sc_theta] + -- We number off the superclass selectors, 1, 2, 3 etc so that we + -- can construct names for the selectors. Thus + -- class (C a, C b) => D a b where ... + -- gives superclass selectors + -- D_sc1, D_sc2 + -- (We used to call them D_C, but now we can have two different + -- superclasses both called C!) + + ; fixM (\ clas -> do { -- Only name generation inside loop + + let { op_tys = [ty | (_,_,ty) <- sig_stuff] + ; sc_tys = mkPredTys sc_theta + ; dict_component_tys = sc_tys ++ op_tys + ; sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names] + ; op_items = [ (mkDictSelId op_name clas, dm_info) + | (op_name, dm_info, _) <- sig_stuff ] } + -- Build the selector id and default method id + + ; dict_con <- buildDataCon datacon_name + (map (const NotMarkedStrict) dict_component_tys) + [{- No labelled fields -}] + tvs [{-No context-}] + [{-No existential tyvars-}] [{-Or context-}] + dict_component_tys + (classTyCon clas) + + ; let { clas = mkClass class_name tvs fds + sc_theta sc_sel_ids op_items + tycon + + ; tycon = mkClassTyCon tycon_name clas_kind tvs + tc_vrcs dict_con + clas flavour tc_isrec + -- A class can be recursive, and in the case of newtypes + -- this matters. For example + -- class C a where { op :: C b => a -> b -> Int } + -- Because C has only one operation, it is represented by + -- a newtype, and it should be a *recursive* newtype. + -- [If we don't make it a recursive newtype, we'll expand the + -- newtype like a synonym, but that will lead to an infinite type] + + ; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind + + ; flavour = case dict_component_tys of + [rep_ty] -> NewTyCon (mkNewTyConRep tycon) + other -> DataTyCon False -- Not an enumeration + } + ; return clas + })} +\end{code} + + diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs new file mode 100644 index 0000000..4916653 --- /dev/null +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -0,0 +1,408 @@ +(c) The University of Glasgow 2002 + +\begin{code} +module IfaceEnv ( + newGlobalBinder, newIPName, newImplicitBinder, + lookupIfaceTop, lookupIfaceExt, + lookupOrig, lookupImplicitOrig, lookupIfaceTc, + newIfaceName, newIfaceNames, + extendIfaceIdEnv, extendIfaceTyVarEnv, + tcIfaceGlobal, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId, + tcIfaceTyVar, tcIfaceDataCon, tcIfaceLclId, + + -- Name-cache stuff + allocateGlobalBinder, extendOrigNameCache, initNameCache + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} TcIface( tcImportDecl ) + +import TcRnMonad +import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) +import HscTypes ( NameCache(..), HscEnv(..), + TyThing, tyThingClass, tyThingTyCon, + ExternalPackageState(..), OrigNameCache, lookupType ) +import TyCon ( TyCon, tyConName ) +import Class ( Class ) +import DataCon ( DataCon, dataConWorkId, dataConName ) +import Var ( TyVar, Id, varName ) +import Name ( Name, nameUnique, nameModule, nameModuleName, + nameOccName, nameSrcLoc, + getOccName, nameParent_maybe, + isWiredInName, nameIsLocalOrFrom, mkIPName, + mkExternalName, mkInternalName ) +import NameEnv +import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, + lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) +import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name ) +import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon, + tupleTyCon, tupleCon ) +import HscTypes ( ExternalPackageState, NameCache, TyThing(..) ) +import Module ( Module, ModuleName, moduleName, mkPackageModule, + emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) +import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply ) +import FiniteMap ( emptyFM, lookupFM, addToFM ) +import BasicTypes ( IPName(..), mapIPName ) +import SrcLoc ( SrcLoc, noSrcLoc ) +import Maybes ( orElse ) + +import Outputable +\end{code} + + +%********************************************************* +%* * + Allocating new Names in the Name Cache +%* * +%********************************************************* + +\begin{code} +newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name +-- Used for source code and interface files, to make the +-- Name for a thing, given its Module and OccName +-- +-- The cache may already already have a binding for this thing, +-- because we may have seen an occurrence before, but now is the +-- moment when we know its Module and SrcLoc in their full glory + +newGlobalBinder mod occ mb_parent loc + = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help + ; name_supply <- getNameCache + ; let (name_supply', name) = allocateGlobalBinder + name_supply mod occ + mb_parent loc + ; setNameCache name_supply' + ; return name } + +allocateGlobalBinder + :: NameCache + -> Module -> OccName -> Maybe Name -> SrcLoc + -> (NameCache, Name) +allocateGlobalBinder name_supply mod occ mb_parent loc + = case lookupOrigNameCache (nsNames name_supply) (moduleName mod) occ of + -- A hit in the cache! We are at the binding site of the name. + -- This is the moment when we know the defining Module and SrcLoc + -- of the Name, so we set these fields in the Name we return. + -- + -- This is essential, to get the right Module in a Name. + -- Also: then (bogus) multiple bindings of the same Name + -- get different SrcLocs can can be reported as such. + -- + -- Possible other reason: it might be in the cache because we + -- encountered an occurrence before the binding site for an + -- implicitly-imported Name. Perhaps the current SrcLoc is + -- better... but not really: it'll still just say 'imported' + -- + -- IMPORTANT: Don't mess with wired-in names. + -- Their wired-in-ness is in their NameSort + -- and their Module is correct. + + Just name | isWiredInName name -> (name_supply, name) + | otherwise -> (new_name_supply, name') + where + uniq = nameUnique name + name' = mkExternalName uniq mod occ mb_parent loc + new_cache = extend_name_cache (nsNames name_supply) mod occ name' + new_name_supply = name_supply {nsNames = new_cache} + + -- Miss in the cache! + -- Build a completely new Name, and put it in the cache + Nothing -> (new_name_supply, name) + where + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniq = uniqFromSupply us1 + name = mkExternalName uniq mod occ mb_parent loc + new_cache = extend_name_cache (nsNames name_supply) mod occ name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} + + +newImplicitBinder :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRnIf m n Name -- Implicit name +-- Called in BuildTyCl to allocate the implicit binders of type/class decls +-- For source type/class decls, this is the first occurrence +-- For iface ones, the LoadIface has alrady allocated a suitable name in the cache +-- +-- An *implicit* name has the base-name as parent +newImplicitBinder base_name mk_sys_occ + = newGlobalBinder (nameModule base_name) + (mk_sys_occ (nameOccName base_name)) + (Just parent_name) + (nameSrcLoc base_name) + where + parent_name = case nameParent_maybe base_name of + Just parent_name -> parent_name + Nothing -> base_name + +lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name +-- This one starts with a ModuleName, not a Module, because +-- we may be simply looking at an occurrence M.x in an interface file. +-- We may enounter this well before finding the binding site for M.x +-- +-- So, even if we get a miss in the original-name cache, we +-- make a new External Name. +-- We fake up +-- Module to AnotherPackage +-- SrcLoc to noSrcLoc +-- They'll be overwritten, in due course, by LoadIface.loadDecl. +lookupOrig mod_name occ = lookupOrig_help mod_name occ Nothing + +lookupImplicitOrig :: Name -> OccName -> TcRnIf m n Name +-- Same as lookupOrig, but install (Just parent) as the +-- parent Name. This is used when looking at the exports +-- of an interface: +-- Suppose module M exports type A.T, and constructor A.MkT +-- Then, we know that A.MkT is an implicit name of A.T, +-- even though we aren't at the binding site of A.T +-- And it's important, because we may simply re-export A.T +-- without ever sucking in the declaration itself. +lookupImplicitOrig name occ + = lookupOrig_help (nameModuleName name) occ (Just name) + +lookupOrig_help :: ModuleName -> OccName -> Maybe Name -> TcRnIf a b Name +-- Local helper, not exported +lookupOrig_help mod_name occ mb_parent + = do { -- First ensure that mod_name and occ are evaluated + -- If not, chaos can ensue: + -- we read the name-cache + -- then pull on mod (say) + -- which does some stuff that modifies the name cache + -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..) + mod `seq` occ `seq` return () + + ; name_supply <- getNameCache + ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of { + Just name -> returnM name ; + Nothing -> do + + { let { (us', us1) = splitUniqSupply (nsUniqs name_supply) + ; uniq = uniqFromSupply us1 + ; name = mkExternalName uniq tmp_mod occ mb_parent noSrcLoc + ; new_cache = extend_name_cache (nsNames name_supply) tmp_mod occ name + ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} + ; tmp_mod = mkPackageModule mod_name + -- Guess at the package-ness for now, becuase we don't know whether + -- this imported module is from the home package or not. + -- If we ever need it, we'll open its interface, and update the cache + -- with a better name (newGlobalBinder) + } + ; setNameCache new_name_supply + ; return name } + }} + +newIPName :: IPName OccName -> TcRnIf m n (IPName Name) +newIPName occ_name_ip + = getNameCache `thenM` \ name_supply -> + let + ipcache = nsIPs name_supply + in + case lookupFM ipcache key of + Just name_ip -> returnM name_ip + Nothing -> setNameCache new_ns `thenM_` + returnM name_ip + where + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniq = uniqFromSupply us1 + name_ip = mapIPName (mkIPName uniq) occ_name_ip + new_ipcache = addToFM ipcache key name_ip + new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} + where + key = occ_name_ip -- Ensures that ?x and %x get distinct Names +\end{code} + + Local helper functions (not exported) + +\begin{code} +lookupOrigNameCache :: OrigNameCache -> ModuleName -> OccName -> Maybe Name +lookupOrigNameCache nc mod_name occ + | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name, -- Boxed tuples from one, + Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other + = -- Special case for tuples; there are too many + -- of them to pre-populate the original-name cache + Just (mk_tup_name tup_info) + where + mk_tup_name (ns, boxity, arity) + | ns == tcName = tyConName (tupleTyCon boxity arity) + | ns == dataName = dataConName (tupleCon boxity arity) + | otherwise = varName (dataConWorkId (tupleCon boxity arity)) + +lookupOrigNameCache nc mod_name occ -- The normal case + = case lookupModuleEnvByName nc mod_name of + Nothing -> Nothing + Just occ_env -> lookupOccEnv occ_env occ + +extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache nc name + = extend_name_cache nc (nameModule name) (nameOccName name) name + +extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extend_name_cache nc mod occ name + = extendModuleEnv_C combine nc mod (unitOccEnv occ name) + where + combine occ_env _ = extendOccEnv occ_env occ name + +getNameCache :: TcRnIf a b NameCache +getNameCache = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; + readMutVar nc_var } + +setNameCache :: NameCache -> TcRnIf a b () +setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv; + writeMutVar nc_var nc } +\end{code} + + +\begin{code} +initNameCache :: UniqSupply -> [Name] -> NameCache +initNameCache us names + = NameCache { nsUniqs = us, + nsNames = initOrigNames names, + nsIPs = emptyFM } + +initOrigNames :: [Name] -> OrigNameCache +initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names +\end{code} + + +%************************************************************************ +%* * + Getting from Names to TyThings +%* * +%************************************************************************ + +\begin{code} +tcIfaceGlobal :: Name -> IfM a TyThing +tcIfaceGlobal name + = do { eps <- getEps + ; hpt <- getHpt + ; case lookupType hpt (eps_PTE eps) name of { + Just thing -> return thing ; + Nothing -> + + setLclEnv () $ do + { env <- getGblEnv + ; case if_rec_types env of + Just (mod, get_type_env) + | nameIsLocalOrFrom mod name + -> do -- It's defined in the module being compiled + { type_env <- get_type_env + ; case lookupNameEnv type_env name of + Just thing -> return thing + Nothing -> pprPanic "tcIfaceGlobal (local): not found:" + (ppr name $$ ppr type_env) } + + other -> tcImportDecl name -- It's imported; go get it + }}} + +tcIfaceTyCon :: IfaceTyCon -> IfL TyCon +tcIfaceTyCon IfaceIntTc = return intTyCon +tcIfaceTyCon IfaceBoolTc = return boolTyCon +tcIfaceTyCon IfaceCharTc = return charTyCon +tcIfaceTyCon IfaceListTc = return listTyCon +tcIfaceTyCon IfacePArrTc = return parrTyCon +tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar) +tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm + ; thing <- tcIfaceGlobal name + ; return (tyThingTyCon thing) } + +tcIfaceClass :: IfaceExtName -> IfL Class +tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name + ; thing <- tcIfaceGlobal name + ; return (tyThingClass thing) } + +tcIfaceDataCon :: IfaceExtName -> IfL DataCon +tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl + ; thing <- tcIfaceGlobal name + ; case thing of + ADataCon dc -> return dc + other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) } + +tcIfaceExtId :: IfaceExtName -> IfL Id +tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl + ; thing <- tcIfaceGlobal name + ; case thing of + AnId id -> return id + other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) } + +------------------------------------------ +tcIfaceLclId :: OccName -> IfL Id +tcIfaceLclId occ + = do { lcl <- getLclEnv + ; return (lookupOccEnv (if_id_env lcl) occ + `orElse` + pprPanic "tcIfaceLclId" (ppr occ)) } + +tcIfaceTyVar :: OccName -> IfL TyVar +tcIfaceTyVar occ + = do { lcl <- getLclEnv + ; return (lookupOccEnv (if_tv_env lcl) occ + `orElse` + pprPanic "tcIfaceTyVar" (ppr occ)) } + +extendIfaceIdEnv :: [Id] -> IfL a -> IfL a +extendIfaceIdEnv ids thing_inside + = do { env <- getLclEnv + ; let { id_env' = extendOccEnvList (if_id_env env) pairs + ; pairs = [(getOccName id, id) | id <- ids] } + ; setLclEnv (env { if_id_env = id_env' }) thing_inside } + +extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a +extendIfaceTyVarEnv tyvars thing_inside + = do { env <- getLclEnv + ; let { tv_env' = extendOccEnvList (if_tv_env env) pairs + ; pairs = [(getOccName tv, tv) | tv <- tyvars] } + ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } +\end{code} + + +%************************************************************************ +%* * + Getting from RdrNames to Names +%* * +%************************************************************************ + +IfaceDecls etc are populated with RdrNames. The RdrNames may either be + + Orig or Unqual when the interface is read from a file + + Exact when the interface is kept by GHCi, and is now + being re-linked with the type environment + +At an occurrence site, to convert the RdrName to Name: + Unqual look up in LocalRdrEnv + Orig look up in OrigNameCache + Exact return the Name + +At a binding site, to bind the RdrName + Unqual we extend the LocalRdrEnv + Orig or Unqual we don't extend the LocalRdrEnv (no need) + +First, we deal with the RdrName -> Name mapping + +\begin{code} +lookupIfaceTc :: IfaceTyCon -> IfL Name +lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext +lookupIfaceTc other_tc = return (ifaceTyConName other_tc) + +lookupIfaceExt :: IfaceExtName -> IfL Name +lookupIfaceExt (ExtPkg mod occ) = lookupOrig mod occ +lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ +lookupIfaceExt (LocalTop occ) = lookupIfaceTop occ +lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ + +lookupIfaceTop :: OccName -> IfL Name +-- Look up a top-level name from the current Iface module +lookupIfaceTop occ + = do { env <- getLclEnv; lookupOrig (if_mod env) occ } + +newIfaceName :: OccName -> IfL Name +newIfaceName occ + = do { uniq <- newUnique + ; return (mkInternalName uniq occ noSrcLoc) } + +newIfaceNames :: [OccName] -> IfL [Name] +newIfaceNames occs + = do { uniqs <- newUniqueSupply + ; return [ mkInternalName uniq occ noSrcLoc + | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } +\end{code} diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs new file mode 100644 index 0000000..041a5f5 --- /dev/null +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -0,0 +1,943 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +%************************************************************************ +%* * +\section[HsCore]{Core-syntax unfoldings in Haskell interface files} +%* * +%************************************************************************ + +We could either use this, or parameterise @GenCoreExpr@ on @Types@ and +@TyVars@ as well. Currently trying the former... MEGA SIGH. + +\begin{code} +module IfaceSyn ( + module IfaceType, -- Re-export all this + + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), + IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), + IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), + + -- Converting things to IfaceSyn + tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule, + + -- Equality + IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, + eqIfDecl, eqIfInst, eqIfRule, + + -- Pretty printing + pprIfaceExpr, pprIfaceDecl + ) where + +#include "HsVersions.h" + +import CoreSyn +import IfaceType + +import FunDeps ( pprFundeps ) +import NewDemand ( StrictSig, pprIfaceStrictSig ) +import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred ) +import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy, + mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType ) +import InstEnv ( DFunId ) +import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) +import NewDemand ( isTopSig ) +import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), + arityInfo, cafInfo, newStrictnessInfo, + workerInfo, unfoldingInfo, inlinePragInfo ) +import TyCon ( ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon, + isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, + isTupleTyCon, tupleTyConBoxity, + tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn, + tyConArity, tyConTyVars, tyConDataConDetails, tyConExtName ) +import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, + dataConTyCon ) +import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) +import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv, + lookupOccEnv, extendOccEnv, emptyOccEnv, + OccSet, unionOccSets, unitOccSet ) +import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName ) +import Module ( ModuleName ) +import CostCentre ( CostCentre, pprCostCentreCore ) +import Literal ( Literal ) +import ForeignCall ( ForeignCall ) +import TysPrim ( alphaTyVars ) +import BasicTypes ( Arity, Activation(..), StrictnessMark, NewOrData(..), + RecFlag(..), boolToRecFlag, Boxity(..), + tupleParens ) +import Outputable +import FastString +import Maybes ( catMaybes ) +import Util ( lengthIs ) + +infixl 3 &&& +infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType` +\end{code} + + +%************************************************************************ +%* * + Data type declarations +%* * +%************************************************************************ + +\begin{code} +data IfaceDecl + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifND :: NewOrData, + ifCtxt :: IfaceContext, -- Context + ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifCons :: DataConDetails IfaceConDecl, + ifRec :: RecFlag, -- Recursive or not? + ifVrcs :: ArgVrcs, + ifGeneric :: Bool -- True <=> generic converter functions available + } -- We need this for imported data decls, since the + -- imported modules may have been compiled with + -- different flags to the current compilation unit + + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifVrcs :: ArgVrcs, + ifSynRhs :: IfaceType -- synonym expansion + } + + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep OccName], -- Functional dependencies + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? + ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + } + + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + ifExtName :: Maybe FastString } + +data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType + -- Nothing => no default method + -- Just False => ordinary polymorphic default method + -- Just True => generic default method + +data IfaceConDecl + = IfaceConDecl OccName -- Constructor name + [IfaceTvBndr] -- Existental tyvars + IfaceContext -- Existential context + [IfaceType] -- Arg types + [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types + [OccName] -- ...ditto... (field labels) + +data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified + -- so that it'll compare alpha-wise + ifDFun :: OccName } -- And the dfun + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before + +data IfaceRule + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfaceExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr + } + | IfaceBuiltinRule IfaceExtName CoreRule -- So that built-in rules can + -- wait in the RulePol + +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + | DiscardedInfo -- HasInfo in the .hi file, but discarded + -- when it was read in +-- Here's why we need this NoInfo/DiscardedInfo stuff +-- * Compile with -O module A, and B which imports A.f +-- * Change function f in A, and recompile without -O +-- * If we read in A.hi and discard IdInfo, the +-- new (empty) IdInfo for f looks like the +-- old (discarded) IdInfo for f +-- => no new version # for f +-- * But that might mean that we fail to recompile B, when +-- actually we should +-- +-- * We also want to ensure that if A.hi was *already* compiled +-- without -O we *don't* then recompile B +-- +-- When we discard IdInfo on *reading* we make it into DiscardedInfo +-- On *writing* we make it NoInfo +-- DiscardedInfo is never written into a file + +data IfaceInfoItem + = HsArity Arity + | HsStrictness StrictSig + | HsUnfold Activation IfaceExpr + | HsNoCafRefs + | HsWorker OccName Arity -- Worker, if any see IdInfo.WorkerInfo + -- for why we want arity here. +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +-------------------------------- +data IfaceExpr + = IfaceLcl OccName + | IfaceExt IfaceExtName + | IfaceType IfaceType + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr OccName [IfaceAlt] + | IfaceLet IfaceBinding IfaceExpr + | IfaceNote IfaceNote IfaceExpr + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType + +data IfaceNote = IfaceSCC CostCentre + | IfaceCoerce IfaceType + | IfaceInlineCall + | IfaceInlineMe + | IfaceCoreNote String + +type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr) + -- Note: OccName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files + +data IfaceConAlt = IfaceDefault + | IfaceDataAlt OccName + | IfaceTupleAlt Boxity + | IfaceLitAlt Literal + +data IfaceBinding + = IfaceNonRec IfaceIdBndr IfaceExpr + | IfaceRec [(IfaceIdBndr, IfaceExpr)] +\end{code} + + +%************************************************************************ +%* * +\subsection[HsCore-print]{Printing Core unfoldings} +%* * +%************************************************************************ + +----------------------------- Printing IfaceDecl ------------------------------------ + +\begin{code} +instance Outputable IfaceDecl where + ppr = pprIfaceDecl + +pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info}) + = sep [ ppr var <+> dcolon <+> ppr ty, + nest 2 (ppr info) ] + +pprIfaceDecl (IfaceForeign {ifName = tycon}) + = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] + +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs}) + = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars) + 4 (vcat [equals <+> ppr mono_ty, + pprVrcs vrcs]) + +pprIfaceDecl (IfaceData {ifND = new_or_data, ifCtxt = context, ifName = tycon, + ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs}) + = hang (ppr new_or_data <+> pp_decl_head context tycon tyvars) + 4 (vcat [pprVrcs vrcs, pprRec isrec, pp_condecls condecls]) + +pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, + ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) + = hang (ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds) + 4 (vcat [pprVrcs vrcs, + pprRec isrec, + sep (map ppr sigs)]) + +pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs +pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec + +instance Outputable IfaceClassOp where + ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty + +pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc +pp_decl_head context thing tyvars + = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars] + +pp_condecls Unknown = ptext SLIT("{- abstract -}") +pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) + +instance Outputable IfaceConDecl where + ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields) + = pprIfaceForAllPart ex_tvs ex_ctxt $ + sep [ppr name <+> sep (map pprParendIfaceType arg_tys), + if null strs then empty + else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)), + if null fields then empty + else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))] + +instance Outputable IfaceRule where + ppr (IfaceRule name act bndrs fn args rhs) + = sep [hsep [doubleQuotes (ftext name), ppr act, + ptext SLIT("forall") <+> pprIfaceBndrs bndrs], + nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args), + ptext SLIT("=") <+> ppr rhs]) + ] + ppr (IfaceBuiltinRule name rule) + = ptext SLIT("Built-in rule for") <+> ppr name + +instance Outputable IfaceInst where + ppr (IfaceInst {ifDFun = dfun_id, ifInstHead = ty}) + = hang (ptext SLIT("instance") <+> ppr ty) + 2 (equals <+> ppr dfun_id) +\end{code} + + +----------------------------- Printing IfaceExpr ------------------------------------ + +\begin{code} +instance Outputable IfaceExpr where + ppr e = pprIfaceExpr noParens e + +pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +pprIfaceExpr add_par (IfaceLcl v) = ppr v +pprIfaceExpr add_par (IfaceExt v) = ppr v +pprIfaceExpr add_par (IfaceLit l) = ppr l +pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty + +pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) +pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as) + +pprIfaceExpr add_par e@(IfaceLam _ _) + = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow, + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] e + collect bs (IfaceLam b e) = collect (b:bs) e + collect bs e = (reverse bs, e) + +pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) + +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) + +pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) + = add_par (sep [ptext SLIT("let {"), + nest 2 (ppr_bind (b, rhs)), + ptext SLIT("} in"), + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) + = add_par (sep [ptext SLIT("letrec {"), + nest 2 (sep (map ppr_bind pairs)), + ptext SLIT("} in"), + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body) + +ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, + arrow <+> pprIfaceExpr noParens rhs] + +ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs) +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + +ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty, + equals <+> pprIfaceExpr noParens rhs] + +------------------ +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args) +pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args) + +------------------ +instance Outputable IfaceNote where + ppr (IfaceSCC cc) = pprCostCentreCore cc + ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty + ppr IfaceInlineCall = ptext SLIT("__inline_call") + ppr IfaceInlineMe = ptext SLIT("__inline_me") + ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s) + +instance Outputable IfaceConAlt where + ppr IfaceDefault = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + -- IfaceTupleAlt is handled by the case-alternative printer + +------------------ +instance Outputable IfaceIdInfo where + ppr NoInfo = empty + ppr DiscardedInfo = ptext SLIT("") + ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}") + +ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag, + parens (pprIfaceExpr noParens unf)] +ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity +ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str +ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs") +ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a +\end{code} + + +%************************************************************************ +%* * + Converting things to their Iface equivalents +%* * +%************************************************************************ + + +\begin{code} +tyThingToIfaceDecl :: Bool -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl +tyThingToIfaceDecl discard_prags ext (AnId id) + = IfaceId { ifName = getOccName id, + ifType = toIfaceType ext (idType id), + ifIdInfo = info } + where + info | discard_prags = NoInfo + | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id)) + +tyThingToIfaceDecl _ ext (AClass clas) + = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, + ifName = getOccName clas, + ifTyVars = toIfaceTvBndrs clas_tyvars, + ifFDs = map toIfaceFD clas_fds, + ifSigs = map toIfaceClassOp op_stuff, + ifRec = boolToRecFlag (isRecursiveTyCon tycon), + ifVrcs = tyConArgVrcs tycon } + where + (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas + tycon = classTyCon clas + + toIfaceClassOp (sel_id, def_meth) + = ASSERT(sel_tyvars == clas_tyvars) + IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty) + 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) = splitForAllTys (idType sel_id) + op_ty = funResultTy rho_ty + + toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) + +tyThingToIfaceDecl _ ext (ATyCon tycon) + | isSynTyCon tycon + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, + ifVrcs = tyConArgVrcs tycon, + ifSynRhs = toIfaceType ext syn_ty } + + | isAlgTyCon tycon + = IfaceData { ifND = new_or_data, + ifCtxt = toIfaceContext ext (tyConTheta tycon), + ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, + ifCons = ifaceConDecls (tyConDataConDetails tycon), + ifRec = boolToRecFlag (isRecursiveTyCon tycon), + ifVrcs = tyConArgVrcs tycon, + ifGeneric = tyConHasGenerics tycon } + + | isForeignTyCon tycon + = IfaceForeign { ifName = getOccName tycon, + ifExtName = tyConExtName tycon } + + | isPrimTyCon tycon || isFunTyCon tycon + -- Needed in GHCi for ':info Int#', for example + = IfaceData { ifND = DataType, + ifCtxt = [], + ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), + ifCons = Unknown, + ifGeneric = False, + ifRec = NonRecursive, + ifVrcs = tyConArgVrcs tycon } + + | otherwise = pprPanic "toIfaceDecl" (ppr tycon) + where + tyvars = tyConTyVars tycon + (_, syn_ty) = getSynTyConDefn tycon + new_or_data | isNewTyCon tycon = NewType + | otherwise = DataType + + ifaceConDecls Unknown = Unknown + ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) + + ifaceConDecl data_con + = IfaceConDecl (getOccName (dataConName data_con)) + (toIfaceTvBndrs ex_tyvars) + (toIfaceContext ext ex_theta) + (map (toIfaceType ext) arg_tys) + strict_marks + (map getOccName field_labels) + where + (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con + field_labels = dataConFieldLabels data_con + strict_marks = dataConStrictMarks data_con + + -- This case only happens in the call to ifaceThing in InteractiveUI + -- Otherwise DataCons are filtered out in ifaceThing_acc +tyThingToIfaceDecl _ ext (ADataCon dc) + = IfaceId { ifName = getOccName dc, + ifType = toIfaceType ext full_ty, + ifIdInfo = NoInfo } + 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))) + +-------------------------- +dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst +dfunToIfaceInst mod dfun_id + = IfaceInst { ifDFun = getOccName dfun_id, + ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty } + where + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id) + head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys)) + -- No need to record the instance context; + -- it's in the dfun anyway + + tidy_ty = tidyTopType (deNoteType head_ty) + -- 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. + + +-------------------------- +toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] +toIfaceIdInfo ext id_info + = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, + wrkr_hsinfo, unfold_hsinfo] + where + ------------ Arity -------------- + arity_info = arityInfo id_info + arity_hsinfo | arity_info == 0 = Nothing + | otherwise = Just (HsArity arity_info) + + ------------ Caf Info -------------- + caf_info = cafInfo id_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 (getOccName 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 (toIfaceExpr ext rhs)) + +-------------------------- +coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule +coreRuleToIfaceRule mod ext (id, BuiltinRule _ _) + = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id))) + +coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map (toIfaceBndr ext) bndrs, + ifRuleHead = ext (getName id), + ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args, + -- Use LHS name-fn for the args + ifRuleRhs = toIfaceExpr ext rhs } + +bogusIfaceRule :: IfaceExtName -> IfaceRule +bogusIfaceRule id_name + = IfaceRule FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name) + +--------------------- +toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr +toIfaceExpr ext (Var v) = toIfaceVar ext v +toIfaceExpr ext (Lit l) = IfaceLit l +toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) +toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) +toIfaceExpr ext (App f a) = toIfaceApp ext f [a] +toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as) +toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) +toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) + +--------------------- +toIfaceNote ext (SCC cc) = IfaceSCC cc +toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) +toIfaceNote ext InlineCall = IfaceInlineCall +toIfaceNote ext InlineMe = IfaceInlineMe +toIfaceNote ext (CoreNote s) = IfaceCoreNote s + +--------------------- +toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r) +toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs] + +--------------------- +toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r) + +--------------------- +toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) + | otherwise = IfaceDataAlt (getOccName dc) + where + tc = dataConTyCon dc + +toIfaceCon (LitAlt l) = IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefault + +--------------------- +toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as) +toIfaceApp ext (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | isTupleTyCon tc && saturated + -> IfaceTuple (tupleTyConBoxity tc) tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map (toIfaceExpr ext) val_args + tc = dataConTyCon dc + + other -> mkIfaceApps ext (toIfaceVar ext v) as + +toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as + +mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as + +--------------------- +toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr +toIfaceVar ext v + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) + -- Foreign calls have special syntax + | isExternalName name = IfaceExt (ext name) + | otherwise = IfaceLcl (nameOccName name) + where + name = idName v + +--------------------- +-- mkLhsNameFn ignores versioning info altogether +-- Used for the LHS of instance decls and rules, where we +-- there's no point in recording version info +mkLhsNameFn :: ModuleName -> Name -> IfaceExtName +mkLhsNameFn this_mod name + | mod == this_mod = LocalTop occ + | otherwise = ExtPkg mod occ + where + mod = nameModuleName name + occ = nameOccName name +\end{code} + + +%************************************************************************ +%* * + Equality, for interface file version generaion only +%* * +%************************************************************************ + +Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is +EqBut, which gives the set of *locally-defined* things whose version must be equal +for the whole thing to be equal. So the key function is eqIfExt, which compares +IfaceExtNames. + +Of course, equality is also done modulo alpha conversion. + +\begin{code} +data IfaceEq + = Equal -- Definitely exactly the same + | NotEqual -- Definitely different + | EqBut OccSet -- The same provided these local things have not changed + +bool :: Bool -> IfaceEq +bool True = Equal +bool False = NotEqual + +zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information +zapEq (EqBut _) = Equal +zapEq other = other + +(&&&) :: IfaceEq -> IfaceEq -> IfaceEq +Equal &&& x = x +NotEqual &&& x = NotEqual +EqBut occs &&& Equal = EqBut occs +EqBut occs &&& NotEqual = NotEqual +EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2) + +--------------------- +eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq +-- This function is the core of the EqBut stuff +eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2) +eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2) +eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1) +eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1) +eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1) +eqIfExt n1 n2 = NotEqual +\end{code} + + +\begin{code} +--------------------- +eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq +eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2) + = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2) + +eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) + = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2) + +eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) + = bool (ifName d1 == ifName d2 && + ifND d1 == ifND d2 && + ifRec d1 == ifRec d2 && + ifVrcs d1 == ifVrcs d2 && + ifGeneric d1 == ifGeneric d2) &&& + eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> + eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& + eq_hsCD env (ifCons d1) (ifCons d2) + ) + +eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) + = bool (ifName d1 == ifName d2) &&& + eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> + eq_ifType env (ifSynRhs d1) (ifSynRhs d2) + ) + +eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {}) + = bool (ifName d1 == ifName d2 && + ifRec d1 == ifRec d2 && + ifVrcs d1 == ifVrcs d2) &&& + eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> + eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& + eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& + eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2) + ) + +eqIfDecl _ _ = NotEqual -- default case + +-- Helper +eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq +eqWith = eq_ifTvBndrs emptyEqEnv + +----------------------- +eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&& + zapEq (ifInstHead d1 `eqIfType` ifInstHead d2) + -- zapEq: for instances, ignore the EqBut part + +eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1) + (IfaceRule n2 a2 bs2 f2 es2 rhs2) + = bool (n1==n2 && a1==a2) &&& + f1 `eqIfExt` f2 &&& + eq_ifBndrs emptyEqEnv bs1 bs2 (\env -> + zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&& + -- zapEq: for the LHSs, ignore the EqBut part + eq_ifaceExpr env rhs1 rhs2) +eqIfRule _ _ = NotEqual + +eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2 +eq_hsCD env Unknown Unknown = Equal +eq_hsCD env d1 d2 = NotEqual + +eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1) + (IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2) + = bool (n1 == n2 && ss1 == ss2 && lbls1 == lbls2) &&& + eq_ifTvBndrs env tvs1 tvs2 (\ env -> + eq_ifContext env cxt1 cxt2 &&& + eq_ifTypes env args1 args2) + +eq_hsFD env (ns1,ms1) (ns2,ms2) + = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2 + +eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2) + = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2 +\end{code} + + +\begin{code} +----------------- +eqIfIdInfo NoInfo NoInfo = Equal +eqIfIdInfo DiscardedInfo DiscardedInfo = Equal -- Should not happen? +eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2 +eqIfIdInfo i1 i2 = NotEqual + +eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2) +eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2) +eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2 +eq_item HsNoCafRefs HsNoCafRefs = Equal +eq_item (HsWorker occ1 a1) (HsWorker occ2 a2) = bool (a1==a2 && occ1==occ2) +eq_item _ _ = NotEqual + +----------------- +eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq +eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2 +eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2 +eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2) +eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2 +eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2 +eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2 +eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2) +eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2 +eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2 + +eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2) + = eq_ifaceExpr env s1 s2 &&& + eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2) + where + eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2) + = bool (eq_ifaceConAlt c1 c2) &&& + eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2) + +eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2) + = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2) + +eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2) + = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2) + where + (bs1,rs1) = unzip as1 + (bs2,rs2) = unzip as2 + + +eq_ifaceExpr env _ _ = NotEqual + +----------------- +eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool +eq_ifaceConAlt IfaceDefault IfaceDefault = True +eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2 +eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2 +eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2 +eq_ifaceConAlt _ _ = False + +----------------- +eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq +eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2) +eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2 +eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal +eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal +eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2) +eq_ifaceNote env _ _ = NotEqual +\end{code} + +\begin{code} +--------------------- +eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2 + +------------------- +eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2 +eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2 +eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2 +eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2 +eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2) +eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2 +eq_ifType env _ _ = NotEqual + +------------------- +eq_ifTypes env = eqListBy (eq_ifType env) + +------------------- +eq_ifContext env a b = eqListBy (eq_ifPredType env) a b + +------------------- +eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2 +eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2 +eq_ifPredType env _ _ = NotEqual + +------------------- +eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2 +eqIfTc IfaceIntTc IfaceIntTc = Equal +eqIfTc IfaceCharTc IfaceCharTc = Equal +eqIfTc IfaceBoolTc IfaceBoolTc = Equal +eqIfTc IfaceListTc IfaceListTc = Equal +eqIfTc IfacePArrTc IfacePArrTc = Equal +eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2) +eqIfTc _ _ = NotEqual +\end{code} + +----------------------------------------------------------- + Support code for equality checking +----------------------------------------------------------- + +\begin{code} +------------------------------------ +type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables + +eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq +eqIfOcc env n1 n2 = case lookupOccEnv env n1 of + Just n1 -> bool (n1 == n2) + Nothing -> bool (n1 == n2) + +extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv +extendEqEnv env n1 n2 | n1 == n2 = env + | otherwise = extendOccEnv env n1 n2 + +emptyEqEnv :: EqEnv +emptyEqEnv = emptyOccEnv + +------------------------------------ +type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq + +eq_ifNakedBndr :: ExtEnv OccName +eq_ifBndr :: ExtEnv IfaceBndr +eq_ifTvBndr :: ExtEnv IfaceTvBndr +eq_ifIdBndr :: ExtEnv IfaceIdBndr + +eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2) + +eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k +eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k +eq_ifBndr _ _ _ _ = NotEqual + +eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2) &&& k (extendEqEnv env v1 v2) +eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2) + +eq_ifBndrs :: ExtEnv [IfaceBndr] +eq_ifIdBndrs :: ExtEnv [IfaceIdBndr] +eq_ifTvBndrs :: ExtEnv [IfaceTvBndr] +eq_ifNakedBndrs :: ExtEnv [OccName] +eq_ifBndrs = eq_bndrs_with eq_ifBndr +eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr +eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr +eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr + +eq_bndrs_with eq env [] [] k = k env +eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k) +eq_bndrs_with eq env _ _ _ = NotEqual +\end{code} + +\begin{code} +eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq +eqListBy eq [] [] = Equal +eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys +eqListBy eq xs ys = NotEqual + +eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq +eqMaybeBy eq Nothing Nothing = Equal +eqMaybeBy eq (Just x) (Just y) = eq x y +eqMaybeBy eq x y = NotEqual +\end{code} diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs new file mode 100644 index 0000000..04ca8eb --- /dev/null +++ b/ghc/compiler/iface/IfaceType.lhs @@ -0,0 +1,384 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% + + This module defines intereace types and binders + +\begin{code} +module IfaceType ( + IfaceType(..), IfaceKind(..), IfacePredType(..), IfaceTyCon(..), + IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, + + IfaceExtName(..), mkIfaceExtName, ifaceTyConName, + + -- Conversion from Type -> IfaceType + toIfaceType, toIfaceKind, toIfacePred, toIfaceContext, + toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, + + -- Printing + pprIfaceKind, pprParendIfaceKind, + pprIfaceType, pprParendIfaceType, pprIfaceContext, + pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs, + getIfaceExt, + tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart + + ) where + +#include "HsVersions.h" + +import Type ( openTypeKind, liftedTypeKind, unliftedTypeKind, + splitFunTy_maybe, eqKind ) +import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType ) +import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) +import Var ( isId, tyVarKind, idType ) +import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName ) +import OccName ( OccName ) +import Name ( Name, getName, getOccName, nameModuleName, nameOccName, isInternalName ) +import Module ( ModuleName ) +import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity ) +import Outputable +import FastString + +#ifdef DEBUG +import TypeRep( crudePprType ) +#endif +\end{code} + + +%************************************************************************ +%* * + IfaceExtName +%* * +%************************************************************************ + +\begin{code} +data IfaceExtName + = ExtPkg ModuleName OccName -- From an external package; no version # + -- Also used for wired-in things regardless + -- of whether they are home-pkg or not + + | HomePkg ModuleName OccName Version -- From another module in home package; + -- has version # + + | LocalTop OccName -- Top-level from the same module as + -- the enclosing IfaceDecl + + | LocalTopSub -- Same as LocalTop, but for a class method or constr + OccName -- Class-meth/constr name + OccName -- Parent class/datatype name + -- LocalTopSub is written into iface files as LocalTop; the parent + -- info is only used when computing version information in MkIface + +mkIfaceExtName name = ExtPkg (nameModuleName name) (nameOccName name) + -- Local helper for wired-in names +\end{code} + + +%************************************************************************ +%* * + Local (nested) binders +%* * +%************************************************************************ + +\begin{code} +data IfaceBndr -- Local (non-top-level) binders + = IfaceIdBndr IfaceIdBndr + | IfaceTvBndr IfaceTvBndr + +type IfaceIdBndr = (OccName, IfaceType) -- OccName, because always local +type IfaceTvBndr = (OccName, IfaceKind) + +------------------------------- +data IfaceKind + = IfaceLiftedTypeKind + | IfaceOpenTypeKind + | IfaceUnliftedTypeKind + | IfaceFunKind IfaceKind IfaceKind + deriving( Eq ) + +------------------------------- +data IfaceType + = IfaceTyVar OccName -- Type variable only, not tycon + | IfaceAppTy IfaceType IfaceType + | IfaceForAllTy IfaceTvBndr IfaceType + | IfacePredTy IfacePredType + | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceFunTy IfaceType IfaceType + +data IfacePredType -- NewTypes are handled as ordinary TyConApps + = IfaceClassP IfaceExtName [IfaceType] + | IfaceIParam (IPName OccName) IfaceType + +type IfaceContext = [IfacePredType] + +data IfaceTyCon -- Abbreviations for common tycons with known names + = IfaceTc IfaceExtName -- The common case + | IfaceIntTc | IfaceBoolTc | IfaceCharTc + | IfaceListTc | IfacePArrTc + | IfaceTupTc Boxity Arity + +ifaceTyConName :: IfaceTyCon -> Name -- Works for all except IfaceTc +ifaceTyConName IfaceIntTc = intTyConName +ifaceTyConName IfaceBoolTc = boolTyConName +ifaceTyConName IfaceCharTc = charTyConName +ifaceTyConName IfaceListTc = listTyConName +ifaceTyConName IfacePArrTc = parrTyConName +ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) +ifaceTyConName (IfaceTc ext) = pprPanic "ifaceTyConName" (ppr ext) +\end{code} + + +%************************************************************************ +%* * + Functions over IFaceTypes +%* * +%************************************************************************ + + +\begin{code} +splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], IfaceContext, IfaceType) +-- Mainly for printing purposes +splitIfaceSigmaTy ty + = (tvs,theta,tau) + where + (tvs, rho) = split_foralls ty + (theta, tau) = split_rho rho + + split_foralls (IfaceForAllTy tv ty) + = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) } + split_foralls rho = ([], rho) + + split_rho (IfaceFunTy (IfacePredTy st) ty) + = case split_rho ty of { (sts, tau) -> (st:sts, tau) } + split_rho tau = ([], tau) +\end{code} + +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ + +Precedence +~~~~~~~~~~ +@ppr_ty@ takes an @Int@ that is the precedence of the context. +The precedence levels are: +\begin{description} +\item[tOP_PREC] No parens required. +\item[fUN_PREC] Left hand argument of a function arrow. +\item[tYCON_PREC] Argument of a type constructor. +\end{description} + +\begin{code} +tOP_PREC = (0 :: Int) -- type in ParseIface.y +fUN_PREC = (1 :: Int) -- btype in ParseIface.y +tYCON_PREC = (2 :: Int) -- atype in ParseIface.y + +noParens :: SDoc -> SDoc +noParens pp = pp + +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty +\end{code} + + +----------------------------- Printing binders ------------------------------------ + +\begin{code} +instance Outputable IfaceExtName where + ppr (ExtPkg mod occ) = ppr mod <> dot <> ppr occ + ppr (HomePkg mod occ vers) = ppr mod <> dot <> ppr occ <> braces (ppr vers) + ppr (LocalTop occ) = ppr occ -- Do we want to distinguish these + ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence? + +getIfaceExt :: ((Name -> IfaceExtName) -> SDoc) -> SDoc +-- Uses the print-unqual info from the SDoc to make an 'ext' +-- which in turn tells toIfaceType when to make a qualified name +-- This is only used when making Iface stuff to print out for the user; +-- e.g. we use this in pprType +getIfaceExt thing_inside + = getPprStyle $ \ sty -> + let + ext nm | unqualStyle sty nm = LocalTop (nameOccName nm) + | isInternalName nm = LocalTop (nameOccName nm) + -- This only happens for Kind constructors, which + -- don't come from any particular module and are unqualified + -- This hack will go away when kinds are separated from types + | otherwise = ExtPkg (nameModuleName nm) (nameOccName nm) + in + thing_inside ext + +instance Outputable IfaceBndr where + ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr + ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr + +pprIfaceBndrs :: [IfaceBndr] -> SDoc +pprIfaceBndrs bs = sep (map ppr bs) + +pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] + +pprIfaceTvBndr :: IfaceTvBndr -> SDoc +pprIfaceTvBndr (tv, IfaceLiftedTypeKind) = ppr tv +pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) + +pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc +pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) +\end{code} + +----------------------------- Printing IfaceType ------------------------------------ + +\begin{code} +--------------------------------- +instance Outputable IfaceKind where + ppr k = pprIfaceKind tOP_PREC k + +pprParendIfaceKind :: IfaceKind -> SDoc +pprParendIfaceKind k = pprIfaceKind tYCON_PREC k + +pprIfaceKind prec IfaceLiftedTypeKind = ptext SLIT("*") +pprIfaceKind prec IfaceUnliftedTypeKind = ptext SLIT("#") +pprIfaceKind prec IfaceOpenTypeKind = ptext SLIT("?") +pprIfaceKind prec (IfaceFunKind k1 k2) = maybeParen prec fUN_PREC $ + sep [ pprIfaceKind fUN_PREC k1, arrow <+> ppr k2] + +--------------------------------- +instance Outputable IfaceType where + ppr ty = ppr_ty ty + +ppr_ty = pprIfaceType tOP_PREC +pprParendIfaceType = pprIfaceType tYCON_PREC + +pprIfaceType :: Int -> IfaceType -> SDoc + + + -- Simple cases +pprIfaceType ctxt_prec (IfaceTyVar tyvar) = ppr tyvar +pprIfaceType ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys +pprIfaceType ctxt_prec (IfacePredTy st) = braces (ppr st) + + -- Function types +pprIfaceType ctxt_prec (IfaceFunTy ty1 ty2) + = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + maybeParen ctxt_prec fUN_PREC $ + sep (pprIfaceType fUN_PREC ty1 : ppr_fun_tail ty2) + where + ppr_fun_tail (IfaceFunTy ty1 ty2) + = (arrow <+> pprIfaceType fUN_PREC ty1) : ppr_fun_tail ty2 + ppr_fun_tail other_ty + = [arrow <+> ppr_ty other_ty] + +pprIfaceType ctxt_prec (IfaceAppTy ty1 ty2) + = maybeParen ctxt_prec tYCON_PREC $ + pprIfaceType fUN_PREC ty1 <+> pprParendIfaceType ty2 + +pprIfaceType ctxt_prec ty@(IfaceForAllTy _ _) + = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (ppr_ty tau)) + where + (tvs, theta, tau) = splitIfaceSigmaTy ty + +------------------- +pprIfaceForAllPart :: [IfaceTvBndr] -> IfaceContext -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt doc + = sep [ppr_tvs, pprIfaceContext ctxt, doc] + where + ppr_tvs | null tvs = empty + | otherwise = ptext SLIT("forall") <+> pprIfaceTvBndrs tvs <> dot + +------------------- +ppr_tc_app ctxt_prec tc [] = ppr tc +ppr_tc_app ctxt_prec IfaceListTc [ty] = brackets (ppr_ty ty) +ppr_tc_app ctxt_prec IfacePArrTc [ty] = pabrackets (ppr_ty ty) +ppr_tc_app ctxt_prec (IfaceTupTc bx arity) tys + | arity == length tys + = tupleParens bx (sep (punctuate comma (map ppr_ty tys))) +ppr_tc_app ctxt_prec tc tys + = maybeParen ctxt_prec tYCON_PREC + (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))]) + +------------------- +instance Outputable IfacePredType where + -- Print without parens + ppr (IfaceIParam ip ty) = hsep [ppr ip, dcolon, ppr ty] + ppr (IfaceClassP cls ts) = ppr cls <+> sep (map pprParendIfaceType ts) + +instance Outputable IfaceTyCon where + ppr (IfaceTc ext) = ppr ext + ppr other_tc = ppr (ifaceTyConName other_tc) + +------------------- +pprIfaceContext :: IfaceContext -> SDoc +-- Prints "(C a, D b) =>", including the arrow +pprIfaceContext [] = empty +pprIfaceContext theta = parens (sep (punctuate comma (map ppr theta))) + <+> ptext SLIT("=>") + +pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") +\end{code} + +%************************************************************************ +%* * + Conversion from Type to IfaceType +%* * +%************************************************************************ + +\begin{code} +---------------- +toIfaceTvBndr tyvar = (getOccName tyvar, toIfaceKind (tyVarKind tyvar)) +toIfaceIdBndr ext id = (getOccName id, toIfaceType ext (idType id)) +toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars + +toIfaceBndr ext var + | isId var = IfaceIdBndr (toIfaceIdBndr ext var) + | otherwise = IfaceTvBndr (toIfaceTvBndr var) + +--------------------- +toIfaceKind :: Kind -> IfaceKind +toIfaceKind k + | k `eqKind` openTypeKind = IfaceOpenTypeKind + | k `eqKind` liftedTypeKind = IfaceLiftedTypeKind + | k `eqKind` unliftedTypeKind = IfaceUnliftedTypeKind + | Just (arg,res) <- splitFunTy_maybe k + = IfaceFunKind (toIfaceKind arg) (toIfaceKind res) +#ifdef DEBUG + | otherwise = pprPanic "toIfaceKind" (crudePprType k) +#endif + +--------------------- +toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType +toIfaceType ext (TyVarTy tv) = IfaceTyVar (getOccName tv) +toIfaceType ext (AppTy t1 t2) = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2) +toIfaceType ext (FunTy t1 t2) = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2) +toIfaceType ext (NewTcApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys) +toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys) +toIfaceType ext (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t) +toIfaceType ext (PredTy st) = IfacePredTy (toIfacePred ext st) +toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app +toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty + +---------------- +mkIfaceTc :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon +mkIfaceTc ext tc + | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | nm == intTyConName = IfaceIntTc + | nm == boolTyConName = IfaceBoolTc + | nm == charTyConName = IfaceCharTc + | nm == listTyConName = IfaceListTc + | nm == parrTyConName = IfacePArrTc + | otherwise = IfaceTc (ext nm) + where + nm = getName tc + +---------------- +toIfaceTypes ext ts = map (toIfaceType ext) ts + +---------------- +toIfacePred ext (ClassP cls ts) = IfaceClassP (ext (getName cls)) (toIfaceTypes ext ts) +toIfacePred ext (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (toIfaceType ext t) + +---------------- +toIfaceContext :: (Name -> IfaceExtName) -> ThetaType -> IfaceContext +toIfaceContext ext cs = map (toIfacePred ext) cs +\end{code} + diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs new file mode 100644 index 0000000..bbdc6b2 --- /dev/null +++ b/ghc/compiler/iface/LoadIface.lhs @@ -0,0 +1,684 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{Dealing with interface files} + +\begin{code} +module LoadIface ( + loadHomeInterface, loadInterface, loadSysInterface, + loadSrcInterface, loadOrphanModules, + readIface, -- Used when reading the module's old interface + predInstGates, ifaceInstGates, ifaceStats, + initExternalPackageState + ) where + +#include "HsVersions.h" + +import DriverState ( v_GhcMode, isCompManagerMode ) +import DriverUtil ( replaceFilenameSuffix ) +import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas ), + opt_InPackage ) +import Parser ( parseIface ) + +import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceInst(..), + IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), + IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName ) +import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc ) +import HscTypes ( HscEnv(..), ModIface(..), emptyModIface, + ExternalPackageState(..), emptyTypeEnv, emptyPool, + lookupIfaceByModName, emptyPackageIfaceTable, + IsBootInterface, mkIfaceFixCache, + Pool(..), DeclPool, InstPool, + RulePool, Gated, addRuleToPool + ) + +import BasicTypes ( Version, Fixity(..), FixityDirection(..) ) +import TcType ( Type, tcSplitTyConApp_maybe ) +import Type ( funTyCon ) +import TcRnMonad + +import PrelNames ( gHC_PRIM_Name ) +import PrelInfo ( ghcPrimExports ) +import PrelRules ( builtinRules ) +import Rules ( emptyRuleBase ) +import InstEnv ( emptyInstEnv ) +import Name ( Name {-instance NamedThing-}, getOccName, + nameModuleName, isInternalName ) +import NameEnv +import MkId ( seqId ) +import Packages ( basePackage ) +import Module ( Module, ModuleName, ModLocation(ml_hi_file), + moduleName, isHomeModule, moduleEnvElts, + extendModuleEnv, lookupModuleEnvByName, moduleUserString + ) +import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc, + mkSuperDictSelOcc, + mkDataConWrapperOcc, mkDataConWorkerOcc ) +import Class ( Class, className ) +import TyCon ( DataConDetails(..), tyConName ) +import SrcLoc ( mkSrcLoc, importedSrcLoc ) +import Maybes ( isJust, mapCatMaybes ) +import StringBuffer ( hGetStringBuffer ) +import FastString ( mkFastString ) +import ErrUtils ( Message ) +import Finder ( findModule, findPackageModule, + hiBootExt, hiBootVerExt ) +import Lexer +import Outputable +import BinIface ( readBinIface ) +import Panic + +import DATA_IOREF ( readIORef ) + +import Directory +\end{code} + + +%************************************************************************ +%* * + loadSrcInterface, loadOrphanModules + + These two are called from TcM-land +%* * +%************************************************************************ + +\begin{code} +loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface +-- This is called for each 'import' declaration in the source code +-- On a failure, fail in the mnad with an error message + +loadSrcInterface doc mod_name want_boot + = do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name + (ImportByUser want_boot) + ; case mb_iface of + Left err -> failWithTc (elaborate err) + Right iface -> return iface + } + where + elaborate err = hang (ptext SLIT("Failed to load interface for") <+> + quotes (ppr mod_name) <> colon) 4 err + +loadOrphanModules :: [ModuleName] -> TcM () +loadOrphanModules mods + | null mods = returnM () + | otherwise = initIfaceTcRn $ + do { traceIf (text "Loading orphan modules:" <+> + fsep (map ppr mods)) + ; mappM_ load mods + ; returnM () } + where + load mod = loadSysInterface (mk_doc mod) mod + mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") +\end{code} + +%********************************************************* +%* * + loadHomeInterface + Called from Iface-land +%* * +%********************************************************* + +\begin{code} +loadHomeInterface :: SDoc -> Name -> IfM lcl ModIface +loadHomeInterface doc name + = ASSERT2( not (isInternalName name), ppr name <+> parens doc ) + loadSysInterface doc (nameModuleName name) + +loadSysInterface :: SDoc -> ModuleName -> IfM lcl ModIface +-- A wrapper for loadInterface that Throws an exception if it fails +loadSysInterface doc mod_name + = do { mb_iface <- loadInterface doc mod_name ImportBySystem + ; case mb_iface of + Left err -> ghcError (ProgramError (showSDoc err)) + Right iface -> return iface } +\end{code} + + +%********************************************************* +%* * + loadInterface + + The main function to load an interface + for an imported module, and put it in + the External Package State +%* * +%********************************************************* + +\begin{code} +loadInterface :: SDoc -> ModuleName -> WhereFrom + -> IfM lcl (Either Message ModIface) +-- If it can't find a suitable interface file, we +-- a) modify the PackageIfaceTable to have an empty entry +-- (to avoid repeated complaints) +-- b) return (Left message) +-- +-- It's not necessarily an error for there not to be an interface +-- file -- perhaps the module has changed, and that interface +-- is no longer used -- but the caller can deal with that by +-- catching the exception + +loadInterface doc_str mod_name from + = do { -- Read the state + env <- getTopEnv + ; let { hpt = hsc_HPT env + ; eps_var = hsc_EPS env } + ; eps <- readMutVar eps_var + ; let { pit = eps_PIT eps } + + -- Check whether we have the interface already + ; case lookupIfaceByModName hpt pit mod_name of { + Just iface + -> returnM (Right iface) ; -- Already loaded + -- The (src_imp == mi_boot iface) test checks that the already-loaded + -- interface isn't a boot iface. This can conceivably happen, + -- if an earlier import had a + -- before we got to real imports. I think. + other -> do + + { if_gbl_env <- getGblEnv + ; let { hi_boot_file = case from of + ImportByUser usr_boot -> usr_boot + ImportBySystem -> sys_boot + + ; mb_dep = lookupModuleEnvByName (if_is_boot if_gbl_env) mod_name + ; sys_boot = case mb_dep of + Just (_, is_boot) -> is_boot + Nothing -> False + -- The boot-ness of the requested interface, + } -- based on the dependencies in directly-imported modules + + -- READ THE MODULE IN + ; read_result <- findAndReadIface doc_str mod_name hi_boot_file + ; case read_result of { + Left err -> do + { let { -- Not found, so add an empty iface to + -- the EPS map so that we don't look again + fake_iface = emptyModIface opt_InPackage mod_name + ; new_pit = extendModuleEnv pit (mi_module fake_iface) fake_iface + ; new_eps = eps { eps_PIT = new_pit } } + ; writeMutVar eps_var new_eps + ; returnM (Left err) } ; + + -- Found and parsed! + Right iface -> + + let { mod = mi_module iface } in + + -- Sanity check. If we're system-importing a module we know nothing at all + -- about, it should be from a different package to this one + WARN( case from of { ImportBySystem -> True; other -> False } && + not (isJust mb_dep) && + isHomeModule mod, + ppr mod ) + + initIfaceLcl (moduleName mod) $ do + -- Load the new ModIface into the External Package State + -- Even home-package interfaces loaded by loadInterface + -- (which only happens in OneShot mode; in Batch/Interactive + -- mode, home-package modules are loaded one by one into the HPT) + -- are put in the EPS. + -- + -- The main thing is to add the ModIface to the PIT, but + -- we also take the + -- IfaceDecls, IfaceInst, IfaceRules + -- out of the ModIface and put them into the big EPS pools + + -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined + --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). + -- If we do loadExport first the wrong info gets into the cache (unless we + -- explicitly tag each export which seems a bit of a bore) + + { new_eps_decls <- loadDecls mod (eps_decls eps) (mi_decls iface) + ; new_eps_insts <- loadInsts mod (eps_insts eps) (mi_insts iface) + ; new_eps_rules <- loadRules mod (eps_rules eps) (mi_rules iface) + + ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", + mi_insts = panic "No mi_insts in PIT", + mi_rules = panic "No mi_rules in PIT" } + + ; new_eps = eps { eps_PIT = extendModuleEnv pit mod final_iface, + eps_decls = new_eps_decls, + eps_rules = new_eps_rules, + eps_insts = new_eps_insts } } + ; writeMutVar eps_var new_eps + ; return (Right final_iface) + }}}}} + +----------------------------------------------------- +-- Loading type/class/value decls +-- We pass the full Module name here, replete with +-- its package info, so that we can build a Name for +-- each binder with the right package info in it +-- All subsequent lookups, including crucially lookups during typechecking +-- the declaration itself, will find the fully-glorious Name +----------------------------------------------------- + +loadDecls :: Module -> DeclPool + -> [(Version, IfaceDecl)] + -> IfM lcl DeclPool +loadDecls mod (Pool decls_map n_in n_out) decls + = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas + ; decls_map' <- foldlM (loadDecl ignore_prags mod) decls_map decls + ; returnM (Pool decls_map' (n_in + length decls) n_out) } + +loadDecl ignore_prags mod decls_map (_version, decl) + = do { main_name <- mk_new_bndr Nothing (ifName decl) + ; let decl' | ignore_prags = zapIdInfo decl + | otherwise = decl + + -- Populate the name cache with final versions of all the subordinate names + ; mapM_ (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl') + + -- Extend the decls pool with a mapping for the main name (only) + ; returnM (extendNameEnv decls_map main_name decl') } + where + -- mk_new_bndr allocates in the name cache the final canonical + -- name for the thing, with the correct + -- * package info + -- * parent + -- * location + -- imported name, to fix the module correctly in the cache + mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc + loc = importedSrcLoc (moduleUserString mod) + +zapIdInfo decl@(IfaceId { ifIdInfo = HasInfo _ }) = decl { ifIdInfo = DiscardedInfo } +zapIdInfo decl = decl + +----------------- +ifaceDeclSubBndrs :: IfaceDecl -> [OccName] +-- *Excludes* the 'main' name, but *includes* the implicitly-bound names +-- Rather revolting, because it has to predict what gets bound + +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs }) + = [tc_occ, dc_occ] ++ + [op | IfaceClassOp op _ _ <- sigs] ++ + [mkSuperDictSelOcc n cls_occ | n <- [1..length sc_ctxt]] ++ + -- The worker and wrapper for the DataCon of the class TyCon + -- are based off the data-con name + [mkDataConWrapperOcc dc_occ, mkDataConWorkerOcc dc_occ] + where + tc_occ = mkClassTyConOcc cls_occ + dc_occ = mkClassDataConOcc cls_occ + +ifaceDeclSubBndrs (IfaceData {ifCons = Unknown}) = [] +ifaceDeclSubBndrs (IfaceData {ifCons = DataCons cons}) + = foldr ((++) . conDeclBndrs) [] cons + +ifaceDeclSubBndrs other = [] + +conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields) + = [con_occ, mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ] + ++ fields + + +----------------------------------------------------- +-- Loading instance decls +----------------------------------------------------- + +loadInsts :: Module -> InstPool -> [IfaceInst] -> IfL InstPool +loadInsts mod (Pool pool n_in n_out) decls + = do { new_pool <- foldlM (loadInstDecl (moduleName mod)) pool decls + ; returnM (Pool new_pool + (n_in + length decls) + n_out) } + +loadInstDecl mod pool decl@(IfaceInst {ifInstHead = inst_ty}) + = do { + -- Find out what type constructors and classes are "gates" for the + -- instance declaration. If all these "gates" are slurped in then + -- we should slurp the instance decl too. + -- + -- We *don't* want to count names in the context part as gates, though. + -- For example: + -- instance Foo a => Baz (T a) where ... + -- + -- Here the gates are Baz and T, but *not* Foo. + -- + -- HOWEVER: functional dependencies make things more complicated + -- class C a b | a->b where ... + -- instance C Foo Baz where ... + -- Here, the gates are really only C and Foo, *not* Baz. + -- That is, if C and Foo are visible, even if Baz isn't, we must + -- slurp the decl. + -- + -- Rather than take fundeps into account "properly", we just slurp + -- if C is visible and *any one* of the Names in the types + -- This is a slightly brutal approximation, but most instance decls + -- are regular H98 ones and it's perfect for them. + -- + -- NOTICE that we rename the type before extracting its free + -- variables. The free-variable finder for a renamed HsType + -- does the Right Thing for built-in syntax like [] and (,). + let { (cls_ext, tc_exts) = ifaceInstGates inst_ty } + ; cls <- lookupIfaceExt cls_ext + ; tcs <- mapM lookupIfaceTc tc_exts + ; let { new_pool = extendNameEnv_C combine pool cls [(tcs, (mod,decl))] + ; combine old _ = (tcs,(mod,decl)) : old } + ; returnM new_pool + } + +----------------------------------------------------- +-- Loading Rules +----------------------------------------------------- + +loadRules :: Module -> RulePool -> [IfaceRule] -> IfL RulePool +loadRules mod pool@(Pool rule_pool n_in n_out) rules + = do { ignore_prags <- doptM Opt_IgnoreInterfacePragmas + ; if ignore_prags then + returnM pool + else do + { new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules + ; returnM (Pool new_pool (n_in + length rules) n_out) } } + +loadRule :: ModuleName -> NameEnv [Gated IfaceRule] -> IfaceRule -> IfL (NameEnv [Gated IfaceRule]) +-- "Gate" the rule simply by a crude notion of the free vars of +-- the LHS. It can be crude, because having too few free vars is safe. +loadRule mod_name pool decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args}) + = do { names <- mapM lookupIfaceExt (fn : arg_fvs) + ; returnM (addRuleToPool pool (mod_name, decl) names) } + where + arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg] + +--------------------------- +crudeIfExprGblFvs :: IfaceExpr -> [IfaceExtName] +-- A crude approximation to the free external names of an IfExpr +-- Returns a subset of the true answer +crudeIfExprGblFvs (IfaceType ty) = get_tcs ty +crudeIfExprGblFvs (IfaceExt v) = [v] +crudeIfExprGblFvs other = [] -- Well, I said it was crude + +get_tcs :: IfaceType -> [IfaceExtName] +-- Get a crude subset of the TyCons of an IfaceType +get_tcs (IfaceTyVar _) = [] +get_tcs (IfaceAppTy t1 t2) = get_tcs t1 ++ get_tcs t2 +get_tcs (IfaceFunTy t1 t2) = get_tcs t1 ++ get_tcs t2 +get_tcs (IfaceForAllTy _ t) = get_tcs t +get_tcs (IfacePredTy st) = case st of + IfaceClassP cl ts -> get_tcs_s ts + IfaceIParam _ t -> get_tcs t +get_tcs (IfaceTyConApp (IfaceTc tc) ts) = tc : get_tcs_s ts +get_tcs (IfaceTyConApp other ts) = get_tcs_s ts + +-- The lists are always small => appending is fine +get_tcs_s :: [IfaceType] -> [IfaceExtName] +get_tcs_s tys = foldr ((++) . get_tcs) [] tys +\end{code} + + +%********************************************************* +%* * + Gating +%* * +%********************************************************* + +Extract the gates of an instance declaration + +\begin{code} +ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon]) +-- Return the class, and the tycons mentioned in the rest of the head +-- We only pick the TyCon at the root of each type, to avoid +-- difficulties with overlap. For example, suppose there are interfaces +-- in the pool for +-- C Int b +-- C a [b] +-- C a [T] +-- Then, if we are trying to resolve (C Int x), we need the first +-- if we are trying to resolve (C x [y]), we need *both* the latter +-- two, even though T is not involved yet, so that we spot the overlap + +ifaceInstGates (IfaceForAllTy _ t) = ifaceInstGates t +ifaceInstGates (IfaceFunTy _ t) = ifaceInstGates t +ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = instHeadGates cls tys +ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other) + -- The other cases should not happen + +instHeadGates cls tys = (cls, mapCatMaybes root_tycon tys) + where + root_tycon (IfaceFunTy _ _) = Just (IfaceTc funTyConExtName) + root_tycon (IfaceTyConApp tc _) = Just tc + root_tycon other = Nothing + +funTyConExtName = mkIfaceExtName (tyConName funTyCon) + + +predInstGates :: Class -> [Type] -> (Name, [Name]) +-- The same function, only this time on the predicate found in a dictionary +predInstGates cls tys + = (className cls, mapCatMaybes root_tycon tys) + where + root_tycon ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> Just (tyConName tc) + Nothing -> Nothing +\end{code} + + +%********************************************************* +%* * +\subsection{Reading an interface file} +%* * +%********************************************************* + +\begin{code} +findAndReadIface :: SDoc -> ModuleName + -> IsBootInterface -- True <=> Look for a .hi-boot file + -- False <=> Look for .hi file + -> IfM lcl (Either Message ModIface) + -- Nothing <=> file not found, or unreadable, or illegible + -- Just x <=> successfully found and parsed + + -- It *doesn't* add an error to the monad, because + -- sometimes it's ok to fail... see notes with loadInterface + +findAndReadIface doc_str mod_name hi_boot_file + = do { traceIf (sep [hsep [ptext SLIT("Reading"), + if hi_boot_file + then ptext SLIT("[boot]") + else empty, + ptext SLIT("interface for"), + ppr mod_name <> semi], + nest 4 (ptext SLIT("reason:") <+> doc_str)]) + + -- Check for GHC.Prim, and return its static interface + ; if mod_name == gHC_PRIM_Name + then returnM (Right ghcPrimIface) + else do + + -- Look for the file + ; mb_found <- ioToIOEnv (findHiFile mod_name hi_boot_file) + ; case mb_found of { + Left files -> do + { traceIf (ptext SLIT("...not found")) + ; dflags <- getDOpts + ; returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) } ; + + Right file_path -> do + + -- Found file, so read it + { traceIf (ptext SLIT("readIFace") <+> text file_path) + ; read_result <- readIface mod_name file_path hi_boot_file + ; case read_result of + Left err -> returnM (Left (badIfaceFile file_path err)) + Right iface -> returnM (Right iface) + }}} + +findHiFile :: ModuleName -> IsBootInterface + -> IO (Either [FilePath] FilePath) +findHiFile mod_name hi_boot_file + = do { + -- In interactive or --make mode, we are *not allowed* to demand-load + -- a home package .hi file. So don't even look for them. + -- This helps in the case where you are sitting in eg. ghc/lib/std + -- and start up GHCi - it won't complain that all the modules it tries + -- to load are found in the home location. + ghci_mode <- readIORef v_GhcMode ; + let { home_allowed = hi_boot_file || + not (isCompManagerMode ghci_mode) } ; + maybe_found <- if home_allowed + then findModule mod_name + else findPackageModule mod_name ; + + case maybe_found of { + Left files -> return (Left files) ; + + Right (_, loc) -> do { -- Don't need module returned by finder + + -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate + let { hi_path = ml_hi_file loc ; + hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ; + hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt + }; + + if not hi_boot_file then + return (Right hi_path) + else do { + hi_ver_exists <- doesFileExist hi_boot_ver_path ; + if hi_ver_exists then return (Right hi_boot_ver_path) + else return (Right hi_boot_path) + }}}} +\end{code} + +@readIface@ tries just the one file. + +\begin{code} +readIface :: ModuleName -> String -> IsBootInterface + -> IfM lcl (Either Message ModIface) + -- Left err <=> file not found, or unreadable, or illegible + -- Right iface <=> successfully found and parsed + +readIface wanted_mod_name file_path is_hi_boot_file + = do { dflags <- getDOpts + ; ioToIOEnv (read_iface dflags wanted_mod_name file_path is_hi_boot_file) } + +read_iface dflags wanted_mod file_path is_hi_boot_file + | is_hi_boot_file -- Read ascii + = do { res <- tryMost (hGetStringBuffer file_path) ; + case res of { + Left exn -> return (Left (text (showException exn))) ; + Right buffer -> + case unP parseIface (mkPState buffer loc dflags) of + PFailed loc1 loc2 err -> return (Left (showPFailed loc1 loc2 err)) + POk _ iface + | wanted_mod == actual_mod -> return (Right iface) + | otherwise -> return (Left err) + where + actual_mod = moduleName (mi_module iface) + err = hiModuleNameMismatchWarn wanted_mod actual_mod + }} + + | otherwise -- Read binary + = do { res <- tryMost (readBinIface file_path) + ; case res of + Right iface -> return (Right iface) + Left exn -> return (Left (text (showException exn))) } + where + loc = mkSrcLoc (mkFastString file_path) 1 0 +\end{code} + + +%********************************************************* +%* * + Wired-in interface for GHC.Prim +%* * +%********************************************************* + +\begin{code} +initExternalPackageState :: ExternalPackageState +initExternalPackageState + = EPS { + eps_PIT = emptyPackageIfaceTable, + eps_PTE = emptyTypeEnv, + eps_inst_env = emptyInstEnv, + eps_rule_base = emptyRuleBase, + eps_decls = emptyPool, + eps_insts = emptyPool, + eps_rules = foldr add emptyPool builtinRules + } + where + -- Initialise the EPS rule pool with the built-in rules + add (fn_name, core_rule) (Pool rules n_in n_out) + = Pool rules' (n_in+1) n_out + where + rules' = addRuleToPool rules iface_rule [fn_name] + iface_rule = (nameModuleName fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule) +\end{code} + + +%********************************************************* +%* * + Wired-in interface for GHC.Prim +%* * +%********************************************************* + +\begin{code} +ghcPrimIface :: ModIface +ghcPrimIface + = (emptyModIface basePackage gHC_PRIM_Name) { + mi_exports = [(gHC_PRIM_Name, ghcPrimExports)], + mi_decls = [], + mi_fixities = fixities, + mi_fix_fn = mkIfaceFixCache fixities + } + where + fixities = [(getOccName seqId, Fixity 0 InfixR)] + -- seq is infixr 0 +\end{code} + +%********************************************************* +%* * +\subsection{Statistics} +%* * +%********************************************************* + +\begin{code} +ifaceStats :: ExternalPackageState -> SDoc +ifaceStats eps + = hcat [text "Renamer stats: ", stats] + where + n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)] + -- This is really only right for a one-shot compile + + Pool _ n_decls_in n_decls_out = eps_decls eps + Pool _ n_insts_in n_insts_out = eps_insts eps + Pool _ n_rules_in n_rules_out = eps_rules eps + + stats = vcat + [int n_mods <+> text "interfaces read", + hsep [ int n_decls_out, text "type/class/variable imported, out of", + int n_decls_in, text "read"], + hsep [ int n_insts_out, text "instance decls imported, out of", + int n_insts_in, text "read"], + hsep [ int n_rules_out, text "rule decls imported, out of", + int n_rules_in, text "read"] + ] +\end{code} + + +%********************************************************* +%* * +\subsection{Errors} +%* * +%********************************************************* + +\begin{code} +badIfaceFile file err + = vcat [ptext SLIT("Bad interface file:") <+> text file, + nest 4 err] + +hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message +hiModuleNameMismatchWarn requested_mod read_mod = + hsep [ ptext SLIT("Something is amiss; requested module name") + , ppr requested_mod + , ptext SLIT("differs from name found in the interface file") + , ppr read_mod + ] + +noIfaceErr dflags mod_name boot_file files + = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) + $$ extra + where + extra + | verbosity dflags < 3 = + text "(use -v to see a list of the files searched for)" + | otherwise = + hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) +\end{code} diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs new file mode 100644 index 0000000..ddc44c6 --- /dev/null +++ b/ghc/compiler/iface/MkIface.lhs @@ -0,0 +1,1030 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% + +\begin{code} +module MkIface ( + showIface, -- Print the iface in Foo.hi + + mkUsageInfo, -- Construct the usage info for a module + + mkIface, -- Build a ModIface from a ModGuts, + -- including computing version information + + checkOldIface -- See if recompilation is required, by + -- comparing version information + ) where +\end{code} + + ----------------------------------------------- + MkIface.lhs deals with versioning + ----------------------------------------------- + +Here's the version-related info in an interface file + + module Foo 8 -- module-version + 3 -- export-list-version + 2 -- rule-version + Usages: -- Version info for what this compilation of Foo imported + Baz 3 -- Module version + [4] -- The export-list version if Foo depended on it + (g,2) -- Function and its version + (T,1) -- Type and its version + + f :: Int -> Int {- Unfolding: \x -> Wib.t[2] x -} + -- The [2] says that f's unfolding + -- mentions verison 2 of Wib.t + + ----------------------------------------------- + Basic idea + ----------------------------------------------- + +Basic idea: + * In the mi_usages information in an interface, we record the + version number of each free variable of the module + + * In mkIface, we compute the version number of each exported thing A.f + by comparing its A.f's info with its new info, and bumping its + version number if it differs. If A.f mentions B.g, and B.g's version + number has changed, then we count A.f as having changed too. + + * In checkOldIface we compare the mi_usages for the module with + the actual version info for all each thing recorded in mi_usages + + +Fixities +~~~~~~~~ +We count A.f as changing if its fixity changes + +Rules +~~~~~ +If a rule changes, we want to recompile any module that might be +affected by that rule. For non-orphan rules, this is relatively easy. +If module M defines f, and a rule for f, just arrange that the version +number for M.f changes if any of the rules for M.f change. Any module +that does not depend on M.f can't be affected by the rule-change +either. + +Orphan rules (ones whose 'head function' is not defined in M) are +harder. Here's what we do. + + * We have a per-module orphan-rule version number which changes if + any orphan rule changes. (It's unaffected by non-orphan rules.) + + * We record usage info for any orphan module 'below' this one, + giving the orphan-rule version number. We recompile if this + changes. + +The net effect is that if an orphan rule changes, we recompile every +module above it. That's very conservative, but it's devilishly hard +to know what it might affect, so we just have to be conservative. + +Instance decls +~~~~~~~~~~~~~~ +In an iface file we have + module A where + instance Eq a => Eq [a] = dfun29 + dfun29 :: ... + +We have a version number for dfun29, covering its unfolding +etc. Suppose we are compiling a module M that imports A only +indirectly. If typechecking M uses this instance decl, we record the +dependency on A.dfun29 as if it were a free variable of the module +(via the tcg_inst_usages accumulator). That means that A will appear +in M's usage list. If the shape of the instance declaration changes, +then so will dfun29's version, triggering a recompilation. + +Adding an instance declaration, or changing an instance decl that is +not currently used, is more tricky. (This really only makes a +difference when we have overlapping instance decls, because then the +new instance decl might kick in to override the old one.) We handle +this in a very similar way that we handle rules above. + + * For non-orphan instance decls, identify one locally-defined tycon/class + mentioned in the decl. Treat the instance decl as part of the defn of that + tycon/class, so that if the shape of the instance decl changes, so does the + tycon/class; that in turn will force recompilation of anything that uses + that tycon/class. + + * For orphan instance decls, act the same way as for orphan rules. + Indeed, we use the same global orphan-rule version number. + +mkUsageInfo +~~~~~~~~~~~ +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 ; +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} +#include "HsVersions.h" + +import HsSyn +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), + IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..), + eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, + eqMaybeBy, eqListBy, + tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule ) +import LoadIface ( readIface, loadInterface, ifaceInstGates ) +import BasicTypes ( Version, initialVersion, bumpVersion ) +import TcRnMonad +import TcRnTypes ( ImportAvails(..), mkModDeps ) +import HscTypes ( ModIface(..), + ModGuts(..), ModGuts, IfaceExport, + GhciMode(..), + HscEnv(..), hscEPS, + Dependencies(..), FixItem(..), + isImplicitTyThing, + mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, + typeEnvElts, + Avails, AvailInfo, GenAvailInfo(..), availName, + ExternalPackageState(..), + Usage(..), IsBootInterface, + Deprecs(..), IfaceDeprecs, Deprecations, + lookupIfaceByModName + ) + + +import CmdLineOpts +import Name ( Name, nameModule, nameOccName, nameParent, isExternalName, + nameParent_maybe, isWiredInName, NamedThing(..) ) +import NameEnv +import NameSet +import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv_C, + OccSet, emptyOccSet, elemOccSet, occSetElts, + extendOccSet, extendOccSetList, + isEmptyOccSet, intersectOccSet, intersectsOccSet ) +import TyCon ( visibleDataCons ) +import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, + ModLocation(..), mkSysModuleNameFS, moduleUserString, + ModuleEnv, emptyModuleEnv, lookupModuleEnv, + extendModuleEnv_C, moduleEnvElts + ) +import Outputable +import DriverUtil ( createDirectoryHierarchy, directoryOf ) +import Util ( sortLt, seqList ) +import Binary ( getBinFileWithDict ) +import BinIface ( writeBinIface, v_IgnoreHiVersion ) +import Unique ( Unique, Uniquable(..) ) +import ErrUtils ( dumpIfSet_dyn, showPass ) +import Digraph ( stronglyConnComp, SCC(..) ) +import FiniteMap +import FastString + +import DATA_IOREF ( writeIORef ) +import Monad ( when ) +import Maybes ( orElse, mapCatMaybes, isNothing, fromJust, expectJust ) +\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 + guts@ModGuts{ mg_module = this_mod, + mg_usages = usages, + mg_deps = deps, + mg_exports = exports, + mg_fix_env = fix_env, + mg_deprecs = src_deprecs, + mg_insts = insts, + mg_rules = rules, + mg_types = type_env } + = do { eps <- hscEPS hsc_env + ; let { this_mod_name = moduleName this_mod + ; ext_nm = mkExtNameFn hsc_env eps this_mod_name + ; decls = [ tyThingToIfaceDecl omit_prags ext_nm thing + | thing <- typeEnvElts type_env + , not (isImplicitTyThing thing) && not (isWiredInName (getName thing)) ] + -- Don't put implicit Ids and class tycons in the interface file + -- Nor wired-in things (GHC knows about them already) + + ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] + ; deprecs = mkIfaceDeprec src_deprecs + ; iface_rules + | omit_prags = [] + | otherwise = sortLt lt_rule $ + map (coreRuleToIfaceRule this_mod_name ext_nm) rules + ; iface_insts = sortLt lt_inst (map (dfunToIfaceInst this_mod_name) insts) + + ; intermediate_iface = ModIface { + mi_module = this_mod, + mi_package = opt_InPackage, + mi_boot = False, + mi_deps = deps, + mi_usages = usages, + mi_exports = groupAvails this_mod exports, + mi_insts = iface_insts, + mi_rules = iface_rules, + mi_fixities = fixities, + mi_deprecs = deprecs, + + -- Left out deliberately: filled in by addVersionInfo + mi_mod_vers = initialVersion, + mi_exp_vers = initialVersion, + mi_rule_vers = initialVersion, + mi_orphan = False, -- Always set by addVersionInfo, but + -- it's a strict field, so we can't omit it. + mi_decls = deliberatelyOmitted "decls", + mi_ver_fn = deliberatelyOmitted "ver_fn", + + -- And build the cached values + mi_dep_fn = mkIfaceDepCache deprecs, + mi_fix_fn = mkIfaceFixCache fixities } + + -- Add version information + ; (new_iface, no_change_at_all, pp_diffs) + = _scc_ "versioninfo" + addVersionInfo maybe_old_iface intermediate_iface decls + } + + -- Write the interface file, if necessary + ; when (not no_change_at_all && ghci_mode /= Interactive) $ do + createDirectoryHierarchy (directoryOf hi_file_path) + writeBinIface hi_file_path new_iface + + -- Debug printing + ; when (dopt Opt_D_dump_hi_diffs dflags) + (printDump (write_diffs maybe_old_iface no_change_at_all pp_diffs)) + ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" + (pprModIface new_iface) + + ; return new_iface } + where + r1 `lt_rule` r2 = ifRuleName r1 < ifRuleName r2 + i1 `lt_inst` i2 = ifDFun i1 < ifDFun i2 + + dflags = hsc_dflags hsc_env + ghci_mode = hsc_mode hsc_env + hi_file_path = ml_hi_file location + omit_prags = dopt Opt_OmitInterfacePragmas dflags + +deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) + +----------------------------- +mkExtNameFn :: HscEnv -> ExternalPackageState -> ModuleName -> Name -> IfaceExtName +mkExtNameFn hsc_env eps this_mod + = ext_nm + where + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + + ext_nm name + | mod_nm == this_mod = case nameParent_maybe name of + Nothing -> LocalTop occ + Just par -> LocalTopSub occ (nameOccName par) + | isWiredInName name = ExtPkg mod_nm occ + | isHomeModule mod = HomePkg mod_nm occ vers + | otherwise = ExtPkg mod_nm occ + where + mod = nameModule name + mod_nm = moduleName mod + occ = nameOccName name + par_occ = nameOccName (nameParent name) + -- The version of the *parent* is the one want + vers = lookupVersion mod_nm par_occ + + lookupVersion :: ModuleName -> OccName -> Version + -- Even though we're looking up a home-package thing, in + -- one-shot mode the imported interfaces may be in the PIT + lookupVersion mod occ + = mi_ver_fn iface occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ) + where + iface = lookupIfaceByModName hpt pit mod `orElse` + pprPanic "lookupVers2" (ppr mod <+> ppr occ) + +----------------------------- +-- Compute version numbers for local decls + +addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi + -> ModIface -- The new interface decls (lacking decls) + -> [IfaceDecl] -- The new decls + -> (ModIface, + Bool, -- True <=> no changes at all; no need to write new Iface + SDoc) -- Differences + +addVersionInfo Nothing new_iface new_decls +-- No old interface, so definitely write a new one! + = (new_iface { mi_orphan = anyNothing getInstKey (mi_insts new_iface) + || anyNothing getRuleKey (mi_rules new_iface), + mi_decls = [(initialVersion, decl) | decl <- new_decls], + mi_ver_fn = \n -> Just initialVersion }, + False, text "No old interface available") + +addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, + mi_exp_vers = old_exp_vers, + mi_rule_vers = old_rule_vers, + mi_decls = old_decls, + mi_ver_fn = old_decl_vers, + mi_fix_fn = old_fixities })) + new_iface@(ModIface { mi_fix_fn = new_fixities }) + new_decls + + | no_change_at_all = (old_iface, True, empty) + | otherwise = (final_iface, False, pp_diffs) + where + final_iface = new_iface { mi_mod_vers = bump_unless no_output_change old_mod_vers, + mi_exp_vers = bump_unless no_export_change old_exp_vers, + mi_rule_vers = bump_unless no_rule_change old_rule_vers, + mi_orphan = not (null new_orph_rules && null new_orph_insts), + mi_decls = decls_w_vers, + mi_ver_fn = mkIfaceVerCache decls_w_vers } + + decls_w_vers = [(add_vers decl, decl) | decl <- new_decls] + + ------------------- + (new_non_orph_insts, new_orph_insts) = mkRuleMap getInstKey (mi_insts new_iface) + (old_non_orph_insts, old_orph_insts) = mkRuleMap getInstKey (mi_insts old_iface) + same_insts occ = eqMaybeBy (eqListBy eqIfInst) + (lookupOccEnv old_non_orph_insts occ) + (lookupOccEnv new_non_orph_insts occ) + + (old_non_orph_rules, old_orph_rules) = mkRuleMap getRuleKey (mi_rules old_iface) + (new_non_orph_rules, new_orph_rules) = mkRuleMap getRuleKey (mi_rules new_iface) + same_rules occ = eqMaybeBy (eqListBy eqIfRule) + (lookupOccEnv old_non_orph_rules occ) + (lookupOccEnv new_non_orph_rules occ) + ------------------- + -- Computing what changed + no_output_change = no_decl_change && no_rule_change && + no_export_change && no_deprec_change + no_export_change = mi_exports new_iface == mi_exports old_iface -- Kept sorted + no_decl_change = isEmptyOccSet changed_occs + no_rule_change = not (changedWrt changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules) + || changedWrt changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)) + no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface + + -- If the usages havn't changed either, we don't need to write the interface file + -- Question: should we also check for equality of mi_deps? + no_other_changes = mi_usages new_iface == mi_usages old_iface + no_change_at_all = no_output_change && no_other_changes + + pp_diffs = vcat [pp_decl_diffs, + pp_change no_export_change "Export list" + (ppr old_exp_vers <+> arrow <+> ppr (mi_exp_vers final_iface)), + pp_change no_rule_change "Rules" + (ppr old_rule_vers <+> arrow <+> ppr (mi_rule_vers final_iface)), + pp_change no_deprec_change "Deprecations" empty, + pp_change no_other_changes "Usages" empty] + pp_change True what info = empty + pp_change False what info = text what <+> ptext SLIT("changed") <+> info + + ------------------- + old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls] + same_fixity n = bool (old_fixities n == new_fixities n) + + ------------------- + -- Adding version info + new_version = bumpVersion old_mod_vers + add_vers decl | occ `elemOccSet` changed_occs = new_version + | otherwise = expectJust "add_vers" (old_decl_vers occ) + -- If it's unchanged, there jolly well + where -- should be an old version number + occ = ifName decl + + ------------------- + changed_occs :: OccSet + changed_occs = computeChangedOccs eq_info + + eq_info :: [(OccName, IfaceEq)] + eq_info = map check_eq new_decls + check_eq new_decl | Just old_decl <- lookupOccEnv old_decl_env occ + = (occ, new_decl `eqIfDecl` old_decl &&& + eq_indirects new_decl) + | otherwise {- No corresponding old decl -} + = (occ, NotEqual) + where + occ = ifName new_decl + + eq_indirects :: IfaceDecl -> IfaceEq + -- When seeing if two decls are the same, remember to + -- check whether any relevant fixity or rules have changed + eq_indirects (IfaceId {ifName = occ}) = eq_ind_occ occ + eq_indirects (IfaceClass {ifName = cls_occ, ifSigs = sigs}) + = same_insts cls_occ &&& + eq_ind_occs [op | IfaceClassOp op _ _ <- sigs] + eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons}) + = same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too + eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleDataCons cons] + eq_indirects other = Equal -- Synonyms and foreign declarations + + eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules + eq_ind_occ occ = same_fixity occ &&& same_rules occ + eq_ind_occs = foldr ((&&&) . eq_ind_occ) Equal + + ------------------- + -- Diffs + pp_decl_diffs :: SDoc -- Nothing => no changes + pp_decl_diffs + | isEmptyOccSet changed_occs = empty + | otherwise + = vcat [ptext SLIT("Changed occs:") <+> ppr (occSetElts changed_occs), + ptext SLIT("Version change for these decls:"), + nest 2 (vcat (map show_change new_decls))] + + eq_env = mkOccEnv eq_info + show_change new_decl + | not (occ `elemOccSet` changed_occs) = empty + | otherwise + = vcat [ppr occ <+> ppr (old_decl_vers occ) <+> arrow <+> ppr new_version, + nest 2 why] + where + occ = ifName new_decl + why = case lookupOccEnv eq_env occ of + Just (EqBut occs) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:"), + nest 2 (braces (fsep (map ppr (occSetElts + (occs `intersectOccSet` changed_occs)))))] + Just NotEqual + | Just old_decl <- lookupOccEnv old_decl_env occ + -> vcat [ptext SLIT("Old:") <+> ppr old_decl, + ptext SLIT("New:") <+> ppr new_decl] + | otherwise + -> ppr occ <+> ptext SLIT("only in new interface") + other -> pprPanic "MkIface.show_change" (ppr occ) + + +computeChangedOccs :: [(OccName, IfaceEq)] -> OccSet +computeChangedOccs eq_info + = foldl add_changes emptyOccSet (stronglyConnComp edges) + where + edges :: [((OccName,IfaceEq), Unique, [Unique])] + edges = [ (node, getUnique occ, map getUnique occs) + | node@(occ, iface_eq) <- eq_info + , let occs = case iface_eq of + EqBut occ_set -> occSetElts occ_set + other -> [] ] + + -- Changes in declarations + add_changes :: OccSet -> SCC (OccName, IfaceEq) -> OccSet + add_changes so_far (AcyclicSCC (occ, iface_eq)) + | changedWrt so_far iface_eq -- This one has changed + = extendOccSet so_far occ + add_changes so_far (CyclicSCC pairs) + | changedWrt so_far (foldr1 (&&&) (map snd pairs)) -- One of this group has changed + = extendOccSetList so_far (map fst pairs) + add_changes so_far other = so_far + +changedWrt :: OccSet -> IfaceEq -> Bool +changedWrt so_far Equal = False +changedWrt so_far NotEqual = True +changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids + +---------------------- +-- mkRuleMap partitions instance decls or rules into +-- (a) an OccEnv for ones that are not orphans, +-- mapping the local OccName to a list of its decls +-- (b) a list of orphan decls +mkRuleMap :: (decl -> Maybe OccName) -- (Just occ) for a non-orphan decl, keyed by occ + -- Nothing for an orphan decl + -> [decl] -- Sorted into canonical order + -> (OccEnv [decl], -- Non-orphan decls associated with their key; + -- each sublist in canonical order + [decl]) -- Orphan decls; in canonical order +mkRuleMap get_key decls + = foldl go (emptyOccEnv, []) decls + where + go (non_orphs, orphs) d + | Just occ <- get_key d + = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs) + | otherwise = (non_orphs, d:orphs) + +-- getXxKey: find at least one local OccName that belongs to this decl + +getInstKey :: IfaceInst -> Maybe OccName +getInstKey (IfaceInst {ifInstHead = inst_ty}) + = case [occ | LocalTop occ <- cls_ext : tc_exts] of + [] -> Nothing + (occ:_) -> Just occ + where + (cls_ext, tcs) = ifaceInstGates inst_ty + tc_exts = [tc | IfaceTc tc <- tcs] + -- Ignore the wired-in IfaceTyCons; the class will do as the key + +getRuleKey :: IfaceRule -> Maybe OccName +getRuleKey (IfaceRule {ifRuleHead = LocalTop occ}) = Just occ +getRuleKey other = Nothing + +anyNothing :: (a -> Maybe b) -> [a] -> Bool +anyNothing p [] = False +anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs + +---------------------- +mkIfaceDeprec :: Deprecations -> IfaceDeprecs +mkIfaceDeprec NoDeprecs = NoDeprecs +mkIfaceDeprec (DeprecAll t) = DeprecAll t +mkIfaceDeprec (DeprecSome env) = DeprecSome (sortLt (<) (nameEnvElts env)) + +---------------------- +write_diffs :: Maybe ModIface -> Bool -> SDoc -> SDoc +write_diffs Nothing _ _ = ptext SLIT("NO OLD INTERFACE FILE") +write_diffs (Just _) True _ = ptext SLIT("INTERFACE UNCHANGED") +write_diffs (Just _) False diffs = sep [ptext SLIT("INTERFACE HAS CHANGED"), nest 2 diffs] + +---------------------- +bump_unless :: Bool -> Version -> Version +bump_unless True v = v -- True <=> no change +bump_unless False v = bumpVersion v +\end{code} + + +%********************************************************* +%* * +\subsection{Keeping track of what we've slurped, and version numbers} +%* * +%********************************************************* + + +\begin{code} +mkUsageInfo :: HscEnv -> ImportAvails -> NameSet -> IO [Usage] +mkUsageInfo hsc_env + (ImportAvails { imp_mods = dir_imp_mods, + imp_dep_mods = dep_mods }) + used_names + = do { eps <- hscEPS hsc_env + ; return (mk_usage_info (eps_PIT eps) (hsc_HPT hsc_env) + dir_imp_mods dep_mods used_names) } + +mk_usage_info pit hpt dir_imp_mods dep_mods proto_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 + used_names = mkNameSet $ -- Eliminate duplicates + [ nameParent n -- Just record usage on the 'main' names + | n <- nameSetToList proto_used_names + , not (isWiredInName n) -- Don't record usages for wired-in names + , isExternalName n -- Ignore internal names + ] + + -- ent_map groups together all the things imported and used + -- from a particular module in this package + ent_map :: ModuleEnv [OccName] + ent_map = foldNameSet add_mv emptyModuleEnv used_names + add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [occ] + where + occ = nameOccName name + mod = nameModule name + add_item occs _ = occ:occs + + usages = mapCatMaybes mkUsage (moduleEnvElts dep_mods) + -- ToDo: do we need to sort into canonical order? + + import_all mod = case lookupModuleEnv dir_imp_mods mod of + Just (_,imp_all) -> isNothing imp_all + Nothing -> False + + -- 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, Bool) -> Maybe Usage + 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_occs + && 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 + orphan_mod = mi_orphan iface + version_env = mi_ver_fn iface + mod_vers = mi_mod_vers iface + rules_vers = mi_rule_vers iface + all_imported = import_all mod + export_vers | all_imported = Just (mi_exp_vers iface) + | otherwise = Nothing + + -- The sort is to put them into canonical order + used_occs = lookupModuleEnv ent_map mod `orElse` [] + ent_vers :: [(OccName,Version)] + ent_vers = [ (occ, version_env occ `orElse` initialVersion) + | occ <- sortLt (<) used_occs] +\end{code} + +\begin{code} +groupAvails :: Module -> Avails -> [(ModuleName, [GenAvailInfo OccName])] + -- 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 [GenAvailInfo OccName] + -- Deliberately use the FastString so we + -- get a canonical ordering + groupFM = foldl add emptyFM avails + + add env avail = addToFM_C (\old _ -> avail':old) env mod_fs [avail'] + where + mod_fs = moduleNameFS (moduleName avail_mod) + avail_mod = nameModule (availName avail) + avail' = sortAvail avail + + a1 `lt` a2 = availName a1 < availName a2 + +sortAvail :: AvailInfo -> GenAvailInfo OccName +-- Convert to OccName, and 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 (nameOccName n) +sortAvail (AvailTC n ns) + | n `elem` ns = AvailTC occ (occ : mk_occs (filter (/= n) ns)) + | otherwise = AvailTC occ ( mk_occs ns) + where + occ = nameOccName n + mk_occs ns = sortLt (<) (map nameOccName ns) +\end{code} + +%************************************************************************ +%* * + Load the old interface file for this module (unless + we have it aleady), and check whether it is up to date + +%* * +%************************************************************************ + +\begin{code} +checkOldIface :: HscEnv + -> Module + -> FilePath -- Where the interface file is + -> Bool -- Source unchanged + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (RecompileRequired, Maybe ModIface) + +checkOldIface hsc_env mod iface_path source_unchanged maybe_iface + = do { showPass (hsc_dflags hsc_env) + ("Checking old interface for " ++ moduleUserString mod) ; + + ; initIfaceIO hsc_env $ + check_old_iface mod iface_path source_unchanged maybe_iface + } + +check_old_iface this_mod iface_path source_unchanged maybe_iface + = -- CHECK WHETHER THE SOURCE HAS CHANGED + ifM (not source_unchanged) + (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) + `thenM_` + + -- If the source has changed and we're in interactive mode, avoid reading + -- an interface; just return the one we might have been supplied with. + getGhciMode `thenM` \ ghci_mode -> + if (ghci_mode == Interactive) && not source_unchanged then + returnM (outOfDate, maybe_iface) + else + + case maybe_iface of { + Just old_iface -> -- Use the one we already have + checkVersions source_unchanged old_iface `thenM` \ recomp -> + returnM (recomp, Just old_iface) + + ; Nothing -> + + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + readIface (moduleName this_mod) iface_path False `thenM` \ read_result -> + case read_result of { + Left err -> -- Old interface file not found, or garbled; give up + traceHiDiffs (text "FYI: cannot read old interface file:" + $$ nest 4 err) `thenM_` + returnM (outOfDate, Nothing) + + ; Right iface -> + + -- We have got the old iface; check its versions + checkVersions source_unchanged iface `thenM` \ recomp -> + returnM (recomp, Just iface) + }} +\end{code} + +@recompileRequired@ is called from the HscMain. It checks whether +a recompilation is required. It needs access to the persistent state, +finder, etc, because it may have to load lots of interface files to +check their versions. + +\begin{code} +type RecompileRequired = Bool +upToDate = False -- Recompile not required +outOfDate = True -- Recompile required + +checkVersions :: Bool -- True <=> source unchanged + -> ModIface -- Old interface + -> IfG RecompileRequired +checkVersions source_unchanged iface + | not source_unchanged + = returnM outOfDate + | otherwise + = traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) `thenM_` + + -- Source code unchanged and no errors yet... carry on + -- First put the dependent-module info in the envt, just temporarily, + -- so that when we look for interfaces we look for the right one (.hi or .hi-boot) + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + updGblEnv (\ gbl -> gbl { if_is_boot = mod_deps }) ( + checkList [checkModUsage u | u <- mi_usages iface] + ) + where + -- This is a bit of a hack really + mod_deps :: ModuleEnv (ModuleName, IsBootInterface) + mod_deps = mkModDeps (dep_mods (mi_deps iface)) + +checkModUsage :: Usage -> IfG RecompileRequired +-- Given the usage information extracted from the old +-- M.hi file for the module being compiled, figure out +-- whether M needs to be recompiled. + +checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers, + usg_rules = old_rule_vers, + usg_exports = maybe_old_export_vers, + usg_entities = old_decl_vers }) + = -- Load the imported interface is possible + let + doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] + in + traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_` + + loadInterface doc_str mod_name ImportBySystem `thenM` \ mb_iface -> + -- Load the interface, but don't complain on failure; + -- Instead, get an Either back which we can test + + case mb_iface of { + Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), + ppr mod_name])); + -- Couldn't find or parse a module mentioned in the + -- old interface file. Don't complain -- it might just be that + -- the current module doesn't need that import and it's been deleted + + Right iface -> + let + new_mod_vers = mi_mod_vers iface + new_decl_vers = mi_ver_fn iface + new_export_vers = mi_exp_vers iface + new_rule_vers = mi_rule_vers iface + in + -- CHECK MODULE + checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile -> + if not recompile then + returnM upToDate + else + + -- CHECK EXPORT LIST + if checkExportList maybe_old_export_vers new_export_vers then + out_of_date_vers (ptext SLIT(" Export list changed")) + (fromJust maybe_old_export_vers) + new_export_vers + else + + -- CHECK RULES + if old_rule_vers /= new_rule_vers then + out_of_date_vers (ptext SLIT(" Rules changed")) + old_rule_vers new_rule_vers + else + + -- CHECK ITEMS ONE BY ONE + checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile -> + if recompile then + returnM outOfDate -- This one failed, so just bail out now + else + up_to_date (ptext SLIT(" Great! The bits I use are up to date")) + } + +------------------------ +checkModuleVersion old_mod_vers new_mod_vers + | new_mod_vers == old_mod_vers + = up_to_date (ptext SLIT("Module version unchanged")) + + | otherwise + = out_of_date_vers (ptext SLIT(" Module version has changed")) + old_mod_vers new_mod_vers + +------------------------ +checkExportList Nothing new_vers = upToDate +checkExportList (Just v) new_vers = v /= new_vers + +------------------------ +checkEntityUsage new_vers (name,old_vers) + = case new_vers name of + + Nothing -> -- We used it before, but it ain't there now + out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) + + Just new_vers -- It's there, but is it up to date? + | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_` + returnM upToDate + | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name) + old_vers new_vers + +up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate +out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate +out_of_date_vers msg old_vers new_vers + = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers]) + +---------------------- +checkList :: [IfG RecompileRequired] -> IfG RecompileRequired +-- This helper is used in two places +checkList [] = returnM upToDate +checkList (check:checks) = check `thenM` \ recompile -> + if recompile then + returnM outOfDate + else + checkList checks +\end{code} + +%************************************************************************ +%* * + Printing interfaces +%* * +%************************************************************************ + +\begin{code} +showIface :: FilePath -> IO () +-- Raad binary interface, and print it out +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 + iface <- Binary.getBinFileWithDict filename + printDump (pprModIface iface) + where +\end{code} + + +\begin{code} +pprModIface :: ModIface -> SDoc +-- Show a ModIface +pprModIface iface + = vcat [ ptext SLIT("interface") + <+> doubleQuotes (ftext (mi_package iface)) + <+> ppr (mi_module iface) <+> ppr (mi_mod_vers iface) + <+> pp_sub_vers + <+> (if mi_orphan iface then char '!' else empty) + <+> int opt_HiVersion + <+> ptext SLIT("where") + , vcat (map pprExport (mi_exports iface)) + , pprDeps (mi_deps iface) + , vcat (map pprUsage (mi_usages iface)) + , pprFixities (mi_fixities iface) + , vcat (map pprIfaceDecl (mi_decls iface)) + , vcat (map ppr (mi_insts iface)) + , vcat (map ppr (mi_rules iface)) + , pprDeprecs (mi_deprecs iface) + ] + where + exp_vers = mi_exp_vers iface + rule_vers = mi_rule_vers iface + + 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} +pprExport :: IfaceExport -> SDoc +pprExport (mod, items) + = hsep [ ptext SLIT("export"), ppr mod, hsep (map pp_avail items) ] + where + pp_avail :: GenAvailInfo OccName -> SDoc + pp_avail (Avail occ) = ppr occ + pp_avail (AvailTC _ []) = empty + pp_avail (AvailTC n (n':ns)) + | n==n' = ppr n <> pp_export ns + | otherwise = ppr n <> char '|' <> pp_export (n':ns) + + pp_export [] = empty + pp_export names = braces (hsep (map ppr names)) + +pprUsage :: Usage -> SDoc +pprUsage 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) ] + where + pp_versions nvs = hsep [ ppr 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 + +pprIfaceDecl :: (Version, IfaceDecl) -> SDoc +pprIfaceDecl (ver, decl) + = ppr_vers ver <+> ppr decl + where + -- Print the version for the decl + ppr_vers v | v == initialVersion = empty + | otherwise = int v + +pprFixities :: [(OccName, Fixity)] -> SDoc +pprFixities [] = empty +pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes + where + pprFix (occ,fix) = ppr fix <+> ppr occ + +pprDeprecs NoDeprecs = empty +pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt) +pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs) + where + pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt) +\end{code} diff --git a/ghc/compiler/iface/TcIface.hi-boot-5 b/ghc/compiler/iface/TcIface.hi-boot-5 new file mode 100644 index 0000000..53b5b04 --- /dev/null +++ b/ghc/compiler/iface/TcIface.hi-boot-5 @@ -0,0 +1,4 @@ +__interface TcIface 1 0 where + +1 tcImportDecl :: Name.Name -> TcRnTypes.IfG TypeRep.TyThing ; + diff --git a/ghc/compiler/iface/TcIface.hi-boot-6 b/ghc/compiler/iface/TcIface.hi-boot-6 new file mode 100644 index 0000000..cac6b13 --- /dev/null +++ b/ghc/compiler/iface/TcIface.hi-boot-6 @@ -0,0 +1,4 @@ +module TcIface where + +tcImportDecl :: Name.Name -> TcRnTypes.IfG TypeRep.TyThing + diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs new file mode 100644 index 0000000..911f4b1 --- /dev/null +++ b/ghc/compiler/iface/TcIface.lhs @@ -0,0 +1,905 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[TcIfaceSig]{Type checking of type signatures in interface files} + +\begin{code} +module TcIface ( + tcImportDecl, typecheckIface, + tcIfaceKind, loadImportedInsts, + tcExtCoreBindings + ) where +#include "HsVersions.h" + +import IfaceSyn +import LoadIface ( loadHomeInterface, predInstGates ) +import IfaceEnv ( lookupIfaceTop, newGlobalBinder, lookupOrig, + extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, + tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId, + tcIfaceDataCon, tcIfaceLclId, + newIfaceName, newIfaceNames ) +import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass ) +import TcRnMonad +import Type ( Kind, openTypeKind, liftedTypeKind, + unliftedTypeKind, mkArrowKind, splitTyConApp, + mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType ) +import TypeRep ( Type(..), PredType(..) ) +import TyCon ( TyCon, tyConName ) +import HscTypes ( ExternalPackageState(..), PackageInstEnv, + TyThing(..), implicitTyThings, + ModIface(..), ModDetails(..), InstPool, + TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv, + DeclPool, RulePool, Pool(..), Gated, addRuleToPool ) +import InstEnv ( extendInstEnv ) +import CoreSyn +import Rules ( extendRuleBaseList ) +import CoreUtils ( exprType ) +import CoreUnfold +import CoreLint ( lintUnfolding ) +import WorkWrap ( mkWrapper ) +import InstEnv ( DFunId ) +import Id ( Id, mkVanillaGlobal, mkLocalId ) +import MkId ( mkFCallId ) +import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), + setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo, + setArityInfo, setInlinePragInfo, setCafInfo, + vanillaIdInfo, newStrictnessInfo ) +import Class ( Class ) +import TyCon ( DataConDetails(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon ) +import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys ) +import TysWiredIn ( tupleCon ) +import Var ( TyVar, mkTyVar, tyVarKind ) +import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, + isWiredInName, wiredInNameTyThing_maybe, nameParent ) +import NameEnv +import OccName ( OccName ) +import Module ( Module, ModuleName, moduleName ) +import UniqSupply ( initUs_ ) +import Outputable +import SrcLoc ( noSrcLoc ) +import Util ( zipWithEqual, dropList, equalLength ) +import Maybes ( expectJust ) +import CmdLineOpts ( DynFlag(..) ) +\end{code} + +This module takes + + IfaceDecl -> TyThing + IfaceType -> Type + etc + +An IfaceDecl is populated with RdrNames, and these are not renamed to +Names before typechecking, because there should be no scope errors etc. + + -- For (b) consider: f = $(...h....) + -- where h is imported, and calls f via an hi-boot file. + -- This is bad! But it is not seen as a staging error, because h + -- is indeed imported. We don't want the type-checker to black-hole + -- when simplifying and compiling the splice! + -- + -- Simple solution: discard any unfolding that mentions a variable + -- bound in this module (and hence not yet processed). + -- The discarding happens when forkM finds a type error. + +%************************************************************************ +%* * +%* tcImportDecl is the key function for "faulting in" * +%* imported things +%* * +%************************************************************************ + +The main idea is this. We are chugging along type-checking source code, and +find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find +it in the EPS type envt. So it + 1 loads GHC.Base.hi + 2 gets the decl for GHC.Base.map + 3 typechecks it via tcIfaceDecl + 4 and adds it to the type env in the EPS + +Note that DURING STEP 4, we may find that map's type mentions a type +constructor that also + +Notice that for imported things we read the current version from the EPS +mutable variable. This is important in situations like + ...$(e1)...$(e2)... +where the code that e1 expands to might import some defns that +also turn out to be needed by the code that e2 expands to. + +\begin{code} +tcImportDecl :: Name -> IfG TyThing +-- Get the TyThing for this Name from an interface file +tcImportDecl name + = do { + -- Make sure the interface is loaded + ; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name } + ; traceIf nd_doc + ; loadHomeInterface nd_doc name + + -- Get the real name of the thing, with a correct nameParent field. + -- Before the interface is loaded, we may have a non-commital 'Nothing' in + -- the namePareent field (made up by IfaceEnv.lookupOrig), but + -- loading the interface updates the name cache. + -- We need the right nameParent field in getThing + ; real_name <- lookupOrig (nameModuleName name) (nameOccName name) + + -- Get the decl out of the EPS + ; main_thing <- ASSERT( real_name == name ) -- Unique should not change! + getThing real_name + + -- Record the import in the type env, + -- slurp any rules it allows in + ; recordImportOf main_thing + + ; let { extra | getName main_thing == real_name = empty + | otherwise = brackets (ptext SLIT("when seeking") <+> ppr real_name) } + ; traceIf (ptext SLIT("...imported decl for") <+> ppr main_thing <+> extra) + + + -- Look up the wanted Name in the type envt; it might be + -- one of the subordinate members of the input thing + ; if real_name == getName main_thing + then return main_thing + else do + { eps <- getEps + ; return (expectJust "tcImportDecl" $ + lookupTypeEnv (eps_PTE eps) real_name) }} + +recordImportOf :: TyThing -> IfG () +-- Update the EPS to record the import of the Thing +-- (a) augment the type environment; this is done even for wired-in +-- things, so that we don't go through this rigmarole a second time +-- (b) slurp in any rules to maintain the invariant that any rule +-- whose gates are all in the type envt, is in eps_rule_base + +recordImportOf thing + = do { (new_things, iface_rules) <- updateEps (\ eps -> + let { new_things = thing : implicitTyThings thing + ; new_type_env = extendTypeEnvList (eps_PTE eps) new_things + -- NB: opportunity for a very subtle loop here! + -- If working out what the implicitTyThings are involves poking + -- any of the fork'd thunks in 'thing', then here's what happens + -- * recordImportOf succeed, extending type-env with a thunk + -- * the next guy to pull on type-env forces the thunk + -- * which pokes the suspended forks + -- * which, to execute, need to consult type-env (to check + -- entirely unrelated types, perhaps) + + ; (new_rules, iface_rules) = selectRules (eps_rules eps) + (map getName new_things) + new_type_env } + in (eps { eps_PTE = new_type_env, eps_rules = new_rules }, + (new_things, iface_rules)) + ) + + -- Now type-check those rules (which may side-effect the EPS again) + ; traceIf (text "tcImport: extend type env" <+> ppr new_things) + ; core_rules <- mapM tc_rule iface_rules + ; updateEps_ (\ eps -> + eps { eps_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules } + ) } + +tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule) + +getThing :: Name -> IfG TyThing +-- Find and typecheck the thing; the Name might be a "subordinate name" +-- of the "main thing" (e.g. the constructor of a data type declaration) +-- The Thing we return is the parent "main thing" + +getThing name + | Just thing <- wiredInNameTyThing_maybe name + = return thing + + | otherwise = do -- The normal case, not wired in + { -- Get the decl from the pool + decl <- updateEps (\ eps -> + let + (decls', decl) = selectDecl (eps_decls eps) name + in + (eps { eps_decls = decls' }, decl)) + + -- Typecheck it + -- Side-effects EPS by faulting in any needed decls + -- (via nested calls to tcImportDecl) + ; initIfaceLcl (nameModuleName name) (tcIfaceDecl decl) } + + +selectDecl :: DeclPool -> Name -> (DeclPool, IfaceDecl) +-- Use nameParent to get the parent name of the thing +selectDecl (Pool decls_map n_in n_out) name + = (Pool decls' n_in (n_out+1), decl) + where + main_name = nameParent name + decl = case lookupNameEnv decls_map main_name of + Nothing -> pprPanic "selectDecl" (ppr main_name <+> ppr name) ; + Just decl -> decl + + decls' = delFromNameEnv decls_map main_name +\end{code} + +%************************************************************************ +%* * + Other interfaces +%* * +%************************************************************************ + +\begin{code} +typecheckIface :: ModIface -> IfG ModDetails +-- Used when we decide not to recompile, but intead to use the +-- interface to construct the type environment for the module +typecheckIface iface + = initIfaceLcl (moduleName (mi_module iface)) $ + do { ty_things <- mapM (tcIfaceDecl . snd) (mi_decls iface) + ; rules <- mapM tcIfaceRule (mi_rules iface) + ; dfuns <- mapM tcIfaceInst (mi_insts iface) + ; return (ModDetails { md_types = mkTypeEnv ty_things, + md_insts = dfuns, + md_rules = rules }) } +\end{code} + + +%************************************************************************ +%* * + Type and class declarations +%* * +%************************************************************************ + +When typechecking a data type decl, we *lazily* (via forkM) typecheck +the constructor argument types. This is in the hope that we may never +poke on those argument types, and hence may never need to load the +interface files for types mentioned in the arg types. + +E.g. + data Foo.S = MkS Baz.T +Mabye we can get away without even loading the interface for Baz! + +This is not just a performance thing. Suppose we have + data Foo.S = MkS Baz.T + data Baz.T = MkT Foo.S +(in different interface files, of course). +Now, first we load and typecheck Foo.S, and add it to the type envt. +If we do explore MkS's argument, we'll load and typecheck Baz.T. +If we explore MkT's argument we'll find Foo.S already in the envt. + +If we typechecked constructor args eagerly, when loading Foo.S we'd try to +typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S... +which isn't done yet. + +All very cunning. However, there is a rather subtle gotcha which bit +me when developing this stuff. When we typecheck the decl for S, we +extend the type envt with S, MkS, and all its implicit Ids. Suppose +(a bug, but it happened) that the list of implicit Ids depended in +turn on the constructor arg types. Then the following sequence of +events takes place: + * we build a thunk for the constructor arg tys + * we build a thunk for the extended type environment (depends on ) + * we write the extended type envt into the global EPS mutvar + +Now we look something up in the type envt + * that pulls on + * which reads the global type envt out of the global EPS mutvar + * but that depends in turn on + +It's subtle, because, it'd work fine if we typechecked the constructor args +eagerly -- they don't need the extended type envt. They just get the extended +type envt by accident, because they look at it later. + +What this means is that the implicitTyThings MUST NOT DEPEND on any of +the forkM stuff. + + +\begin{code} +tcIfaceDecl :: IfaceDecl -> IfL TyThing + +tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) + = do { name <- lookupIfaceTop occ_name + ; ty <- tcIfaceType iface_type + ; info <- tcIdInfo name ty info + ; return (AnId (mkVanillaGlobal name ty info)) } + +tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name, + ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt, + ifCons = rdr_cons, + ifVrcs = arg_vrcs, ifRec = is_rec, + ifGeneric = want_generic }) + = do { tc_name <- lookupIfaceTop occ_name + ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do + + { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt) + + ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $ + tcIfaceCtxt rdr_ctxt + -- The reason for laziness here is to postpone + -- looking at the context, because the class may not + -- be in the type envt yet. E.g. + -- class Real a where { toRat :: a -> Ratio Integer } + -- data (Real a) => Ratio a = ... + -- We suck in the decl for Real, and type check it, which sucks + -- in the data type Ratio; but we must postpone typechecking the + -- context + + ; tycon <- fixM ( \ tycon -> do + { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons + ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons + arg_vrcs is_rec want_generic + ; return tycon + }) + ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) + ; return (ATyCon tycon) + } } + +tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, + ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs}) + = bindIfaceTyVars tv_bndrs $ \ tyvars -> do + { tc_name <- lookupIfaceTop occ_name + ; rhs_ty <- tcIfaceType rdr_rhs_ty + ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs)) + } + +tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, + ifFDs = rdr_fds, ifSigs = rdr_sigs, + ifVrcs = tc_vrcs, ifRec = tc_isrec }) + = bindIfaceTyVars tv_bndrs $ \ tyvars -> do + { cls_name <- lookupIfaceTop occ_name + ; ctxt <- tcIfaceCtxt rdr_ctxt + ; sigs <- mappM tc_sig rdr_sigs + ; fds <- mappM tc_fd rdr_fds + ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs + ; return (AClass cls) } + where + tc_sig (IfaceClassOp occ dm rdr_ty) + = do { op_name <- lookupIfaceTop occ + ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty) + -- Must be done lazily for just the same reason as the + -- context of a data decl: the type sig might mention the + -- class being defined + ; return (op_name, dm, op_ty) } + + mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty] + + tc_fd (tvs1, tvs2) = do { tvs1' <- mappM tcIfaceTyVar tvs1 + ; tvs2' <- mappM tcIfaceTyVar tvs2 + ; return (tvs1', tvs2') } + +tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) + = do { name <- lookupIfaceTop rdr_name + ; return (ATyCon (mkForeignTyCon name ext_name + liftedTypeKind 0 [])) } + +tcIfaceDataCons tycon tyvars ctxt Unknown + = returnM Unknown + +tcIfaceDataCons tycon tyvars ctxt (DataCons cs) + = mappM tc_con_decl cs `thenM` \ data_cons -> + returnM (DataCons data_cons) + where + tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls) + = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do + { name <- lookupIfaceTop occ + ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here + + -- Read the argument types, but lazily to avoid faulting in + -- the component types unless they are really needed + ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ; + + ; lbl_names <- mappM lookupIfaceTop field_lbls + + ; buildDataCon name stricts lbl_names + tyvars ctxt ex_tyvars ex_theta + arg_tys tycon + } + mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args] +\end{code} + + +%************************************************************************ +%* * + Instances +%* * +%************************************************************************ + +The gating story for instance declarations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking for a dict (C t1..tn), we slurp in instance decls for +C that + mention at least one of the type constructors + at the roots of t1..tn + +Why "at least one" rather than "all"? Because functional dependencies +complicate the picture. Consider + class C a b | a->b where ... + instance C Foo Baz where ... +Here, the gates are really only C and Foo, *not* Baz. +That is, if C and Foo are visible, even if Baz isn't, we must +slurp the decl, even if Baz is thus far completely unknown to the +system. + +Why "roots of the types"? Reason is overlap. For example, suppose there +are interfaces in the pool for + (a) C Int b + (b) C a [b] + (c) C a [T] +Then, if we are trying to resolve (C Int x), we need (a) +if we are trying to resolve (C x [y]), we need *both* (b) and (c), +even though T is not involved yet, so that we spot the overlap. + +\begin{code} +loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv +loadImportedInsts cls tys + = do { -- Get interfaces for wired-in things, such as Integer + -- Any non-wired-in tycons will already be loaded, else + -- we couldn't have them in the Type + ; this_mod <- getModule + ; let { (cls_gate, tc_gates) = predInstGates cls tys + ; imp_wi n = isWiredInName n && this_mod /= nameModule n + ; wired_tcs = filter imp_wi tc_gates } + -- Wired-in tycons not from this module. The "this-module" + -- test bites only when compiling Base etc, because loadHomeInterface + -- barfs if it's asked to load a non-existent interface + ; if null wired_tcs then returnM () + else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs) + + ; eps_var <- getEpsVar + ; eps <- readMutVar eps_var + + -- Suck in the instances + ; let { (inst_pool', iface_insts) + = selectInsts (eps_insts eps) cls_gate tc_gates } + + ; traceTc (text "loadImportedInsts" <+> vcat [ppr cls <+> ppr tys, + text "new pool" <+> ppr inst_pool', + text "new insts" <+> ppr iface_insts]) + + -- Empty => finish up rapidly, without writing to eps + ; if null iface_insts then + return (eps_inst_env eps) + else do + { writeMutVar eps_var (eps {eps_insts = inst_pool'}) + + -- Typecheck the new instances + ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts) + + -- And put them in the package instance environment + ; updateEps ( \ eps -> + let + inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns + in + (eps { eps_inst_env = inst_env' }, inst_env') + )}} + where + wired_doc = ptext SLIT("Need home inteface for wired-in thing") + +tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst) + +tcIfaceInst :: IfaceInst -> IfL DFunId +tcIfaceInst (IfaceInst { ifDFun = dfun_occ }) + = tcIfaceExtId (LocalTop dfun_occ) + +selectInsts :: InstPool -> Name -> [Name] -> (InstPool, [(ModuleName, IfaceInst)]) +selectInsts pool@(Pool insts n_in n_out) cls tycons + = (Pool insts' n_in (n_out + length iface_insts), iface_insts) + where + (insts', iface_insts) + = case lookupNameEnv insts cls of { + Nothing -> (insts, []) ; + Just gated_insts -> + + case foldl choose ([],[]) gated_insts of { + (_, []) -> (insts, []) ; -- None picked + (gated_insts', iface_insts') -> + + (extendNameEnv insts cls gated_insts', iface_insts') }} + + -- Reverses the gated decls, but that doesn't matter + choose (gis, decls) (gates, decl) + | any (`elem` tycons) gates = (gis, decl:decls) + | otherwise = ((gates,decl) : gis, decls) +\end{code} + +%************************************************************************ +%* * + Rules +%* * +%************************************************************************ + +We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars +are in the type environment. However, remember that typechecking a Rule may +(as a side effect) augment the type envt, and so we may need to iterate the process. + +\begin{code} +selectRules :: RulePool + -> [Name] -- Names of things being added + -> TypeEnv -- New type env, including things being added + -> (RulePool, [(ModuleName, IfaceRule)]) +selectRules (Pool rules n_in n_out) new_names type_env + = (Pool rules' n_in (n_out + length iface_rules), iface_rules) + where + (rules', iface_rules) = foldl select_one (rules, []) new_names + + select_one :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Name + -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) + select_one (rules, decls) name + = case lookupNameEnv rules name of + Nothing -> (rules, decls) + Just gated_rules -> foldl filter_rule (delFromNameEnv rules name, decls) gated_rules + + filter_rule :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Gated IfaceRule + -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) + filter_rule (rules, decls) (rule_fvs, rule) + = case [fv | fv <- rule_fvs, not (fv `elemNameEnv` type_env)] of + [] -> -- No remaining FVs, so slurp it + (rules, rule:decls) + fvs -> -- There leftover fvs, so toss it back in the pool + (addRuleToPool rules rule fvs, decls) + +tcIfaceRule :: IfaceRule -> IfL IdCoreRule +tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs }) + = bindIfaceBndrs bndrs $ \ bndrs' -> + do { fn <- tcIfaceExtId fn_rdr + ; args' <- mappM tcIfaceExpr args + ; rhs' <- tcIfaceExpr rhs + ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) } + +tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule) + = do { fn <- tcIfaceExtId fn_rdr + ; returnM (fn, core_rule) } +\end{code} + + +%************************************************************************ +%* * + Types +%* * +%************************************************************************ + +\begin{code} +tcIfaceKind :: IfaceKind -> Kind +tcIfaceKind IfaceOpenTypeKind = openTypeKind +tcIfaceKind IfaceLiftedTypeKind = liftedTypeKind +tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind +tcIfaceKind (IfaceFunKind k1 k2) = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2) + +----------------------------------------- +tcIfaceType :: IfaceType -> IfL Type +tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } +tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } +tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } +tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkGenTyConApp tc' ts') } +tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } +tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') } + +tcIfaceTypes tys = mapM tcIfaceType tys + +----------------------------------------- +tcIfacePredType :: IfacePredType -> IfL PredType +tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } +tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') } + +----------------------------------------- +tcIfaceCtxt :: IfaceContext -> IfL ThetaType +tcIfaceCtxt sts = mappM tcIfacePredType sts +\end{code} + + +%************************************************************************ +%* * + Core +%* * +%************************************************************************ + +\begin{code} +tcIfaceExpr :: IfaceExpr -> IfL CoreExpr +tcIfaceExpr (IfaceType ty) + = tcIfaceType ty `thenM` \ ty' -> + returnM (Type ty') + +tcIfaceExpr (IfaceLcl name) + = tcIfaceLclId name `thenM` \ id -> + returnM (Var id) + +tcIfaceExpr (IfaceExt gbl) + = tcIfaceExtId gbl `thenM` \ id -> + returnM (Var id) + +tcIfaceExpr (IfaceLit lit) + = returnM (Lit lit) + +tcIfaceExpr (IfaceFCall cc ty) + = tcIfaceType ty `thenM` \ ty' -> + newUnique `thenM` \ u -> + returnM (Var (mkFCallId u cc ty')) + +tcIfaceExpr (IfaceTuple boxity args) + = mappM tcIfaceExpr args `thenM` \ args' -> + let + -- Put the missing type arguments back in + con_args = map (Type . exprType) args' ++ args' + in + returnM (mkApps (Var con_id) con_args) + where + arity = length args + con_id = dataConWorkId (tupleCon boxity arity) + + +tcIfaceExpr (IfaceLam bndr body) + = bindIfaceBndr bndr $ \ bndr' -> + tcIfaceExpr body `thenM` \ body' -> + returnM (Lam bndr' body') + +tcIfaceExpr (IfaceApp fun arg) + = tcIfaceExpr fun `thenM` \ fun' -> + tcIfaceExpr arg `thenM` \ arg' -> + returnM (App fun' arg') + +tcIfaceExpr (IfaceCase scrut case_bndr alts) + = tcIfaceExpr scrut `thenM` \ scrut' -> + newIfaceName case_bndr `thenM` \ case_bndr_name -> + let + scrut_ty = exprType scrut' + case_bndr' = mkLocalId case_bndr_name scrut_ty + tc_app = splitTyConApp scrut_ty + -- NB: Won't always succeed (polymoprhic case) + -- but won't be demanded in those cases + -- NB: not tcSplitTyConApp; we are looking at Core here + -- look through non-rec newtypes to find the tycon that + -- corresponds to the datacon in this case alternative + in + extendIfaceIdEnv [case_bndr'] $ + mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> + returnM (Case scrut' case_bndr' alts') + +tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = tcIfaceExpr rhs `thenM` \ rhs' -> + bindIfaceId bndr $ \ bndr' -> + tcIfaceExpr body `thenM` \ body' -> + returnM (Let (NonRec bndr' rhs') body') + +tcIfaceExpr (IfaceLet (IfaceRec pairs) body) + = bindIfaceIds bndrs $ \ bndrs' -> + mappM tcIfaceExpr rhss `thenM` \ rhss' -> + tcIfaceExpr body `thenM` \ body' -> + returnM (Let (Rec (bndrs' `zip` rhss')) body') + where + (bndrs, rhss) = unzip pairs + +tcIfaceExpr (IfaceNote note expr) + = tcIfaceExpr expr `thenM` \ expr' -> + case note of + IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> + returnM (Note (Coerce to_ty' + (exprType expr')) expr') + IfaceInlineCall -> returnM (Note InlineCall expr') + IfaceInlineMe -> returnM (Note InlineMe expr') + IfaceSCC cc -> returnM (Note (SCC cc) expr') + IfaceCoreNote n -> returnM (Note (CoreNote n) expr') + +------------------------- +tcIfaceAlt _ (IfaceDefault, names, rhs) + = ASSERT( null names ) + tcIfaceExpr rhs `thenM` \ rhs' -> + returnM (DEFAULT, [], rhs') + +tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) + = ASSERT( null names ) + tcIfaceExpr rhs `thenM` \ rhs' -> + returnM (LitAlt lit, [], rhs') + +-- A case alternative is made quite a bit more complicated +-- by the fact that we omit type annotations because we can +-- work them out. True enough, but its not that easy! +tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs) + = let + tycon_mod = nameModuleName (tyConName tycon) + in + tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con -> + newIfaceNames arg_occs `thenM` \ arg_names -> + let + ex_tyvars = dataConExistentialTyVars con + main_tyvars = tyConTyVars tycon + ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars] + ex_tys' = mkTyVarTys ex_tyvars' + arg_tys = dataConArgTys con (inst_tys ++ ex_tys') + id_names = dropList ex_tyvars arg_names + arg_ids +#ifdef DEBUG + | not (equalLength id_names arg_tys) + = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$ + (ppr main_tyvars <+> ppr ex_tyvars) $$ + ppr arg_tys) + | otherwise +#endif + = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys + in + ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars, + ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars ) + extendIfaceTyVarEnv ex_tyvars' $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs `thenM` \ rhs' -> + returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs') + +tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) + = newIfaceNames arg_occs `thenM` \ arg_names -> + let + [con] = tyConDataCons tycon + arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys + in + ASSERT( isTupleTyCon tycon ) + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs `thenM` \ rhs' -> + returnM (DataAlt con, arg_ids, rhs') +\end{code} + + +\begin{code} +tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core +tcExtCoreBindings mod [] = return [] +tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs) + +do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind] +do_one mod (IfaceNonRec bndr rhs) thing_inside + = do { rhs' <- tcIfaceExpr rhs + ; bndr' <- newExtCoreBndr mod bndr + ; extendIfaceIdEnv [bndr'] $ do + { core_binds <- thing_inside + ; return (NonRec bndr' rhs' : core_binds) }} + +do_one mod (IfaceRec pairs) thing_inside + = do { bndrs' <- mappM (newExtCoreBndr mod) bndrs + ; extendIfaceIdEnv bndrs' $ do + { rhss' <- mappM tcIfaceExpr rhss + ; core_binds <- thing_inside + ; return (Rec (bndrs' `zip` rhss') : core_binds) }} + where + (bndrs,rhss) = unzip pairs +\end{code} + + +%************************************************************************ +%* * + IdInfo +%* * +%************************************************************************ + +\begin{code} +tcIdInfo name ty NoInfo = return vanillaIdInfo +tcIdInfo name ty DiscardedInfo = return vanillaIdInfo +tcIdInfo name ty (HasInfo iface_info) + = foldlM tcPrag init_info iface_info + where + -- Set the CgInfo to something sensible but uninformative before + -- we start; default assumption is that it has CAFs + init_info = vanillaIdInfo + + tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity) + tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str) + + -- The next two are lazy, so they don't transitively suck stuff in + tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity + tcPrag info (HsUnfold inline_prag expr) + = tcPragExpr name expr `thenM` \ maybe_expr' -> + let + -- maybe_expr' doesn't get looked at if the unfolding + -- is never inspected; so the typecheck doesn't even happen + unfold_info = case maybe_expr' of + Nothing -> noUnfolding + Just expr' -> mkTopUnfolding expr' + in + returnM (info `setUnfoldingInfoLazily` unfold_info + `setInlinePragInfo` inline_prag) +\end{code} + +\begin{code} +tcWorkerInfo ty info wkr_name arity + = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId (LocalTop wkr_name)) + + -- We return without testing maybe_wkr_id, but as soon as info is + -- looked at we will test it. That's ok, because its outside the + -- knot; and there seems no big reason to further defer the + -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking + -- over the unfolding until it's actually used does seem worth while.) + ; us <- newUniqueSupply + + ; returnM (case mb_wkr_id of + Nothing -> info + Just wkr_id -> add_wkr_info us wkr_id info) } + where + doc = text "Worker for" <+> ppr wkr_name + add_wkr_info us wkr_id info + = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id + `setWorkerInfo` HasWorker wkr_id arity + + mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id) + + -- We are relying here on strictness info always appearing + -- before worker info, fingers crossed .... + strict_sig = case newStrictnessInfo info of + Just sig -> sig + Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr_name) +\end{code} + +For unfoldings we try to do the job lazily, so that we never type check +an unfolding that isn't going to be looked at. + +\begin{code} +tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr) +tcPragExpr name expr + = forkM_maybe doc $ + tcIfaceExpr expr `thenM` \ core_expr' -> + + -- Check for type consistency in the unfolding + ifOptM Opt_DoCoreLinting ( + case lintUnfolding noSrcLoc [{- in scope -}] core_expr' of + Nothing -> returnM () + Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg) + ) `thenM_` + + returnM core_expr' + where + doc = text "Unfolding of" <+> ppr name +\end{code} + + + +%************************************************************************ +%* * + Bindings +%* * +%************************************************************************ + +\begin{code} +bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a +bindIfaceBndr (IfaceIdBndr bndr) thing_inside + = bindIfaceId bndr thing_inside +bindIfaceBndr (IfaceTvBndr bndr) thing_inside + = bindIfaceTyVar bndr thing_inside + +bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a +bindIfaceBndrs [] thing_inside = thing_inside [] +bindIfaceBndrs (b:bs) thing_inside + = bindIfaceBndr b $ \ b' -> + bindIfaceBndrs bs $ \ bs' -> + thing_inside (b':bs') + +----------------------- +bindIfaceId :: (OccName, IfaceType) -> (Id -> IfL a) -> IfL a +bindIfaceId (occ, ty) thing_inside + = do { name <- newIfaceName occ + ; ty' <- tcIfaceType ty + ; let { id = mkLocalId name ty' } + ; extendIfaceIdEnv [id] (thing_inside id) } + +bindIfaceIds :: [(OccName, IfaceType)] -> ([Id] -> IfL a) -> IfL a +bindIfaceIds bndrs thing_inside + = do { names <- newIfaceNames occs + ; tys' <- mappM tcIfaceType tys + ; let { ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' } + ; extendIfaceIdEnv ids (thing_inside ids) } + where + (occs,tys) = unzip bndrs + + +----------------------- +newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id +newExtCoreBndr mod (occ, ty) + = do { name <- newGlobalBinder mod occ Nothing noSrcLoc + ; ty' <- tcIfaceType ty + ; return (mkLocalId name ty') } + +----------------------- +bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a +bindIfaceTyVar (occ,kind) thing_inside + = do { name <- newIfaceName occ + ; let tyvar = mk_iface_tyvar name kind + ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } + +bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTyVars bndrs thing_inside + = do { names <- newIfaceNames occs + ; let tyvars = zipWith mk_iface_tyvar names kinds + ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } + where + (occs,kinds) = unzip bndrs + +mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind) +\end{code}