X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=e116da7075ce09795dca6e017710ce82026da6b0;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hp=bae0405988cfaa12cd4ea36fc50735f8107e71d6;hpb=686d87447e2186e2aa55e1a925f0a3a8e94872f5;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index bae0405..e116da7 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -105,6 +105,7 @@ tcImportDecl :: Name -> TcM TyThing tcImportDecl name | Just thing <- wiredInNameTyThing_maybe name = do { initIfaceTcRn (loadWiredInHomeIface name) + -- See Note [Loading instances] in LoadIface ; return thing } | otherwise = do { traceIf (text "tcImportDecl" <+> ppr name) @@ -115,7 +116,8 @@ tcImportDecl name checkWiredInTyCon :: TyCon -> TcM () -- Ensure that the home module of the TyCon (and hence its instances) --- are loaded. It might not be a wired-in tycon (see the calls in TcUnify), +-- are loaded. See See Note [Loading instances] in LoadIface +-- It might not be a wired-in tycon (see the calls in TcUnify), -- in which case this is a no-op. checkWiredInTyCon tc | not (isWiredInName tc_name) @@ -558,7 +560,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', @@ -591,57 +592,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 tycons + ; 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 @@ -709,6 +717,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) @@ -757,8 +769,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) @@ -789,12 +801,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') @@ -802,13 +814,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 } @@ -962,14 +976,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 @@ -981,16 +989,39 @@ 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) -- Ditto want to ensure that RULES are loaded too +-- See Note [Loading instances] in LoadIface ifCheckWiredInThing name = do { mod <- getIfModule -- Check whether we are typechecking the interface for this