X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=d4cd503ffef282b2c1c9b117732702ca0abf98dd;hp=f76fa7811e92e9788a11028540cb1baaca4374c2;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=1e37b7f52ea9ac1965fd11edffbfca61b6fa0965 diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index f76fa78..d4cd503 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -20,8 +20,9 @@ import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst ) import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), - IfaceConDecls(..), IfaceIdInfo(..) ) -import IfaceEnv ( newGlobalBinder ) + IfaceConDecls(..), IfaceFamInst(..), + IfaceIdInfo(..) ) +import IfaceEnv ( newGlobalBinder, lookupIfaceTc ) import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), Deprecs(..), Dependencies(..), emptyModIface, EpsStats(..), GenAvailInfo(..), @@ -35,6 +36,7 @@ import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), import BasicTypes ( Version, initialVersion, Fixity(..), FixityDirection(..), isMarkedStrict ) import TcRnMonad +import Type ( TyThing(..) ) import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) @@ -47,9 +49,9 @@ import NameEnv import MkId ( seqId ) import Module import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, - mkClassDataConOcc, mkSuperDictSelOcc, - mkDataConWrapperOcc, mkDataConWorkerOcc, - mkNewTyCoOcc ) + mkClassDataConOcc, mkSuperDictSelOcc, + mkDataConWrapperOcc, mkDataConWorkerOcc, + mkNewTyCoOcc, mkInstTyCoOcc ) import SrcLoc ( importedSrcLoc ) import Maybes ( MaybeErr(..) ) import ErrUtils ( Message ) @@ -62,6 +64,7 @@ import BinIface ( readBinIface, v_IgnoreHiWay ) import Binary ( getBinFileWithDict ) import Panic ( ghcError, tryMost, showException, GhcException(..) ) import List ( nub ) +import Maybe ( isJust ) import DATA_IOREF ( writeIORef ) \end{code} @@ -192,7 +195,6 @@ loadInterface doc_str mod from -- READ THE MODULE IN ; read_result <- findAndReadIface doc_str mod hi_boot_file - ; dflags <- getDOpts ; case read_result of { Failed err -> do { let fake_iface = emptyModIface mod @@ -205,7 +207,7 @@ loadInterface doc_str mod from ; returnM (Failed err) } ; -- Found and parsed! - Succeeded (iface, file_path) -- Sanity check: + Succeeded (iface, file_path) -- Sanity check: | ImportBySystem <- from, -- system-importing... modulePackageId (mi_module iface) == thisPackage dflags, -- a home-package module... @@ -269,6 +271,10 @@ badDepMsg mod -- 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 +-- +-- We handle ATs specially. They are not main declarations, but also not +-- implict things (in particular, adding them to `implicitTyThings' would mess +-- things up in the renaming/type checking of source programs). ----------------------------------------------------- addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv @@ -283,16 +289,20 @@ loadDecls ignore_prags ver_decls ; return (concat thingss) } -loadDecl :: Bool -- Don't load pragmas into the decl pool +loadDecl :: Bool -- Don't load pragmas into the decl pool -> Module -> (Version, IfaceDecl) - -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the - -- TyThings are forkM'd thunks + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the + -- TyThings are forkM'd thunks loadDecl ignore_prags mod (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl main_name <- mk_new_bndr mod Nothing (ifName decl) - ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl) + ; parent_name <- case ifFamily decl of -- make family the parent + Just famTyCon -> lookupIfaceTc famTyCon + _ -> return main_name + ; implicit_names <- mapM (mk_new_bndr mod (Just parent_name)) + (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily -- NB. firstly, the laziness is there in case we never need the @@ -304,9 +314,12 @@ loadDecl ignore_prags mod (_version, decl) ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of Just thing -> thing - Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (stripped_decl) ) + Nothing -> + pprPanic "loadDecl" (ppr main_name <+> + ppr n $$ ppr (stripped_decl)) - ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) } + ; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names] + } -- We build a list from the *known* names, with (lookup n) thunks -- as the TyThings. That way we can extend the PTE without poking the -- thunks @@ -324,6 +337,11 @@ loadDecl ignore_prags mod (_version, decl) (importedSrcLoc (showSDoc (ppr (moduleName mod)))) -- ToDo: qualify with the package name if necessary + ifFamily (IfaceData { + ifFamInst = Just (IfaceFamInst {ifFamInstTyCon = famTyCon})}) + = Just famTyCon + ifFamily _ = Nothing + doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) discardDeclPrags :: IfaceDecl -> IfaceDecl @@ -345,12 +363,12 @@ ifaceDeclSubBndrs :: IfaceDecl -> [OccName] -- -- If you change this, make sure you change HscTypes.implicitTyThings in sync -ifaceDeclSubBndrs IfaceClass { ifCtxt = sc_ctxt, - ifName = cls_occ, - ifSigs = sigs } +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) = co_occs ++ [tc_occ, dc_occ, dcww_occ] ++ - [op | IfaceClassOp op _ _ <- sigs] ++ + [op | IfaceClassOp op _ _ <- sigs] ++ + [ifName at | at <- ats ] ++ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] where n_ctxt = length sc_ctxt @@ -359,7 +377,7 @@ ifaceDeclSubBndrs IfaceClass { ifCtxt = sc_ctxt, dc_occ = mkClassDataConOcc cls_occ co_occs | is_newtype = [mkNewTyCoOcc tc_occ] | otherwise = [] - dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker + dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper is_newtype = n_sigs + n_ctxt == 1 -- Sigh @@ -369,13 +387,18 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( IfCon { ifConOcc = con_occ, - ifConFields = fields})}) - = fields ++ [con_occ, mkDataConWrapperOcc con_occ, mkNewTyCoOcc tc_occ] - -- Wrapper, no worker; see MkId.mkDataConIds + ifConFields = fields + }), + ifFamInst = famInst}) + = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ] + ++ famInstCo famInst tc_occ -ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfDataTyCon cons, + ifFamInst = famInst}) = nub (concatMap ifConFields cons) -- Eliminate duplicate fields ++ concatMap dc_occs cons + ++ famInstCo famInst tc_occ where dc_occs con_decl | has_wrapper = [con_occ, work_occ, wrap_occ] @@ -386,9 +409,15 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) wrap_occ = mkDataConWrapperOcc con_occ work_occ = mkDataConWorkerOcc con_occ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) + || not (null . ifConEqSpec $ con_decl) + || isJust famInst -- ToDo: may miss strictness in existential dicts ifaceDeclSubBndrs _other = [] + +-- coercion for data/newtype family instances +famInstCo Nothing baseOcc = [] +famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] \end{code} @@ -578,7 +607,6 @@ pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface = vcat [ ptext SLIT("interface") - <+> ppr_package (mi_package iface) <+> ppr (mi_module iface) <+> pp_boot <+> ppr (mi_mod_vers iface) <+> pp_sub_vers <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) @@ -596,8 +624,6 @@ pprModIface iface where pp_boot | mi_boot iface = ptext SLIT("[boot]") | otherwise = empty - ppr_package HomePackage = empty - ppr_package (ExtPackage id) = doubleQuotes (ppr id) exp_vers = mi_exp_vers iface rule_vers = mi_rule_vers iface