X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=db8c4fbed82362859c561e9cd7de6f9d533354be;hb=e4828ab96fc2ba5250a6676e4c1653602f8846c7;hp=7e6406fe710c176aacedea08bea843ea0caf4a6f;hpb=3c4a732b0b011cf356eed1ecd4fdc4d5f1aab193;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7e6406f..db8c4fb 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -6,6 +6,13 @@ Type checking of type signatures in interface files \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, @@ -217,7 +224,6 @@ typecheckIface iface , md_rules = rules , md_vect_info = vect_info , md_exports = exports - , md_modBreaks = emptyModBreaks } } \end{code} @@ -560,7 +566,6 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ; rhs' <- tcIfaceExpr rhs ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args - ; lcl <- getLclEnv ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs', @@ -593,57 +598,64 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd \begin{code} tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo tcIfaceVectInfo mod typeEnv (IfaceVectInfo - { ifaceVectInfoCCVar = vars - , ifaceVectInfoCCTyCon = tycons - , ifaceVectInfoCCTyConReuse = tyconsReuse + { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse }) - = do { ccVars <- mapM ccVarMapping vars - ; tyConRes1 <- mapM ccTyConMapping tycons - ; tyConRes2 <- mapM ccTyConReuseMapping tycons - ; let (ccTyCons, ccDataCons, ccIsos) = unzip3 (tyConRes1 ++ tyConRes2) + = do { vVars <- mapM vectVarMapping vars + ; tyConRes1 <- mapM vectTyConMapping tycons + ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse + ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2) ; return $ VectInfo - { vectInfoCCVar = mkVarEnv ccVars - , vectInfoCCTyCon = mkNameEnv ccTyCons - , vectInfoCCDataCon = mkNameEnv (concat ccDataCons) - , vectInfoCCIso = mkNameEnv ccIsos + { vectInfoVar = mkVarEnv vVars + , vectInfoTyCon = mkNameEnv vTyCons + , vectInfoDataCon = mkNameEnv (concat vDataCons) + , vectInfoPADFun = mkNameEnv vPAs + , vectInfoIso = mkNameEnv vIsos } } where - ccVarMapping name - = do { ccName <- lookupOrig mod (mkCloOcc (nameOccName name)) - ; let { var = lookupVar name - ; ccVar = lookupVar ccName + vectVarMapping name + = do { vName <- lookupOrig mod (mkVectOcc (nameOccName name)) + ; let { var = lookupVar name + ; vVar = lookupVar vName } - ; return (var, (var, ccVar)) + ; return (var, (var, vVar)) } - ccTyConMapping name - = do { ccName <- lookupOrig mod (mkCloTyConOcc (nameOccName name)) - ; isoName <- lookupOrig mod (mkCloIsoOcc (nameOccName name)) + vectTyConMapping name + = do { vName <- lookupOrig mod (mkVectTyConOcc (nameOccName name)) + ; paName <- lookupOrig mod (mkPADFunOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) ; let { tycon = lookupTyCon name - ; ccTycon = lookupTyCon ccName + ; vTycon = lookupTyCon vName + ; paTycon = lookupVar paName ; isoTycon = lookupVar isoName } - ; ccDataCons <- mapM ccDataConMapping (tyConDataCons tycon) - ; return ((name, (tycon, ccTycon)), -- (T, T_CC) - ccDataCons, -- list of (Ci, Ci_CC) + ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon) + ; return ((name, (tycon, vTycon)), -- (T, T_v) + vDataCons, -- list of (Ci, Ci_v) + (vName, (vTycon, paTycon)), -- (T_v, paT) (name, (tycon, isoTycon))) -- (T, isoT) } - ccTyConReuseMapping name - = do { isoName <- lookupOrig mod (mkCloIsoOcc (nameOccName name)) + vectTyConReuseMapping name + = do { paName <- lookupOrig mod (mkPADFunOcc (nameOccName name)) + ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name)) ; let { tycon = lookupTyCon name + ; paTycon = lookupVar paName ; isoTycon = lookupVar isoName - ; ccDataCons = [ (dataConName dc, (dc, dc)) + ; vDataCons = [ (dataConName dc, (dc, dc)) | dc <- tyConDataCons tycon] } ; return ((name, (tycon, tycon)), -- (T, T) - ccDataCons, -- list of (Ci, Ci) + vDataCons, -- list of (Ci, Ci) + (name, (tycon, paTycon)), -- (T, paT) (name, (tycon, isoTycon))) -- (T, isoT) } - ccDataConMapping datacon + vectDataConMapping datacon = do { let name = dataConName datacon - ; ccName <- lookupOrig mod (mkCloDataConOcc (nameOccName name)) - ; let ccDataCon = lookupDataCon ccName - ; return (name, (datacon, ccDataCon)) + ; vName <- lookupOrig mod (mkVectDataConOcc (nameOccName name)) + ; let vDataCon = lookupDataCon vName + ; return (name, (datacon, vDataCon)) } -- lookupVar name = case lookupTypeEnv typeEnv name of @@ -711,6 +723,10 @@ tcIfaceExpr (IfaceLcl name) = tcIfaceLclId name `thenM` \ id -> returnM (Var id) +tcIfaceExpr (IfaceTick modName tickNo) + = tcIfaceTick modName tickNo `thenM` \ id -> + returnM (Var id) + tcIfaceExpr (IfaceExt gbl) = tcIfaceExtId gbl `thenM` \ id -> returnM (Var id) @@ -759,8 +775,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts) -- corresponds to the datacon in this case alternative in extendIfaceIdEnv [case_bndr'] $ - mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> - tcIfaceType ty `thenM` \ ty' -> + mappM (tcIfaceAlt scrut' tc_app) alts `thenM` \ alts' -> + tcIfaceType ty `thenM` \ ty' -> returnM (Case scrut' case_bndr' ty' alts') tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) @@ -791,12 +807,12 @@ tcIfaceExpr (IfaceNote note expr) IfaceCoreNote n -> returnM (Note (CoreNote n) expr') ------------------------- -tcIfaceAlt _ (IfaceDefault, names, rhs) +tcIfaceAlt _ _ (IfaceDefault, names, rhs) = ASSERT( null names ) tcIfaceExpr rhs `thenM` \ rhs' -> returnM (DEFAULT, [], rhs') -tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) +tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) = ASSERT( null names ) tcIfaceExpr rhs `thenM` \ rhs' -> returnM (LitAlt lit, [], rhs') @@ -804,13 +820,15 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, 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_strs, rhs) +tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) = do { con <- tcIfaceDataCon data_occ - ; ASSERT2( con `elem` tyConDataCons tycon, - ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) - tcIfaceDataAlt con inst_tys arg_strs rhs } +#ifdef DEBUG + ; ifM (not (con `elem` tyConDataCons tycon)) + (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) +#endif + ; tcIfaceDataAlt con inst_tys arg_strs rhs } -tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) +tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) = ASSERT( isTupleTyCon tycon ) do { let [data_con] = tyConDataCons tycon ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } @@ -964,14 +982,8 @@ tcIfaceGlobal name -- Wired-in things include TyCons, DataCons, and Ids = do { ifCheckWiredInThing name; return thing } | otherwise - = do { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { - Just thing -> return thing ; - Nothing -> do - - { env <- getGblEnv - ; case if_rec_types env of { + = do { env <- getGblEnv + ; case if_rec_types env of { -- Note [Tying the knot] Just (mod, get_type_env) | nameIsLocalOrFrom mod name -> do -- It's defined in the module being compiled @@ -983,12 +995,34 @@ tcIfaceGlobal name ; other -> do + { (eps,hpt) <- getEpsAndHpt + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of { + Just thing -> return thing ; + Nothing -> do + { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of Failed err -> failIfM err Succeeded thing -> return thing }}}}} +-- Note [Tying the knot] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The if_rec_types field is used in two situations: +-- +-- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T +-- Then we look up M.T in M's type environment, which is splatted into if_rec_types +-- after we've built M's type envt. +-- +-- b) In ghc --make, during the upsweep, we encounter M.hs, whose interface M.hi +-- is up to date. So we call typecheckIface on M.hi. This splats M.T into +-- if_rec_types so that the (lazily typechecked) decls see all the other decls +-- +-- In case (b) it's important to do the if_rec_types check *before* looking in the HPT +-- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its +-- emasculated form (e.g. lacking data constructors). + ifCheckWiredInThing :: Name -> IfL () -- Even though we are in an interface file, we want to make -- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)