X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=710b68ce007bffa33838e931bbf4337e4714165c;hb=d78d04173296841b5949ebce640f444dcfb026f2;hp=f9e91144b2af4204765b111bef78fd4ea280bbbb;hpb=5e0ea427646a5474dd7c659b0713c6a62d8c99c7;p=ghc-hetmet.git diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index f9e9114..710b68c 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,8 @@ import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), import BasicTypes ( Version, initialVersion, Fixity(..), FixityDirection(..), isMarkedStrict ) import TcRnMonad +import Type ( TyThing(..) ) +import Class ( classATs ) import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) @@ -47,9 +50,9 @@ import NameEnv import MkId ( seqId ) import Module import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, - mkClassDataConOcc, mkSuperDictSelOcc, - mkDataConWrapperOcc, mkDataConWorkerOcc, - mkNewTyCoOcc ) + mkClassDataConOcc, mkSuperDictSelOcc, + mkDataConWrapperOcc, mkDataConWorkerOcc, + mkNewTyCoOcc, mkInstTyTcOcc, mkInstTyCoOcc ) import SrcLoc ( importedSrcLoc ) import Maybes ( MaybeErr(..) ) import ErrUtils ( Message ) @@ -62,6 +65,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} @@ -269,6 +273,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 +291,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 +316,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 +339,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 +365,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 @@ -369,12 +389,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] + 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] @@ -385,9 +411,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}