From 07f3c0c8ebbcc5298167b5b705a1660519b395c4 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 15 Sep 2006 21:33:31 +0000 Subject: [PATCH] Massive patch for the first months work adding System FC to GHC #31 Fri Aug 4 18:13:56 EDT 2006 Manuel M T Chakravarty * Massive patch for the first months work adding System FC to GHC #31 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- compiler/specialise/Rules.lhs | 5 ++++- compiler/specialise/SpecConstr.lhs | 26 ++++---------------------- compiler/specialise/Specialise.lhs | 5 +++-- 3 files changed, 11 insertions(+), 25 deletions(-) diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index c7edd8f..35a0bdd 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -25,6 +25,7 @@ import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( tcEqExprX ) import PprCore ( pprRules ) import Type ( TvSubstEnv ) +import Coercion ( coercionKind ) import TcType ( tcSplitTyConApp_maybe ) import CoreTidy ( tidyRules ) import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName, @@ -468,7 +469,9 @@ match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) match menv subst (Type ty1) (Type ty2) = match_ty menv subst ty1 ty2 -match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2) +match menv subst (Cast e1 co1) (Cast e2 co2) + | (from1, to1) <- coercionKind co1 + , (from2, to2) <- coercionKind co2 = do { subst1 <- match_ty menv subst to1 to2 ; subst2 <- match_ty menv subst1 from1 from2 ; match menv subst2 e1 e2 } diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 65835d9..46cea9b 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -18,10 +18,9 @@ import CoreSubst ( Subst, mkSubst, substExpr ) import CoreTidy ( tidyRules ) import PprCore ( pprRules ) import WwLib ( mkWorkerArgs ) -import DataCon ( dataConRepArity, isVanillaDataCon, dataConTyVars ) +import DataCon ( dataConRepArity, dataConTyVars ) import Type ( Type, tyConAppArgs, tyVarsOfTypes ) import Rules ( matchN ) -import Unify ( coreRefineTys ) import Id ( Id, idName, idType, isDataConWorkId_maybe, mkUserLocal, mkSysLocal, idUnfolding, isLocalId ) import Var ( Var ) @@ -483,28 +482,11 @@ extendCaseBndrs env case_bndr scrut con alt_bndrs Var v -> lookupVarEnv cur_scope v `orElse` Other other -> Other - extend_data_con data_con - | isVanillaDataCon data_con = extendCons env1 scrut case_bndr (CV con vanilla_args) - | otherwise = extendCons env2 scrut case_bndr (CV con gadt_args) - -- Note env2 for GADTs + extend_data_con data_con = + extendCons env1 scrut case_bndr (CV con vanilla_args) where - vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ - map varToCoreExpr alt_bndrs - - gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs - -- This call generates some bogus warnings from substExpr, - -- because it's inconvenient to put all the Ids in scope - -- Will be fixed when we move to FC - - (alt_tvs, _) = span isTyVar alt_bndrs - Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr) - subst = mkSubst in_scope tv_subst emptyVarEnv -- No Id substitition - in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst)) - - env2 | is_local = env1 - | otherwise = env1 { cons = refineConstrEnv subst (cons env) } - + varsToCoreExprs alt_bndrs extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv extendCons env scrut case_bndr val diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 3646f91..fa9d253 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -624,7 +624,9 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails) specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs) specExpr subst (Var v) = returnSM (specVar subst v, emptyUDs) specExpr subst (Lit lit) = returnSM (Lit lit, emptyUDs) - +specExpr subst (Cast e co) = + specExpr subst e `thenSM` \ (e', uds) -> + returnSM ((Cast e' (substTy subst co)), uds) specExpr subst (Note note body) = specExpr subst body `thenSM` \ (body', uds) -> returnSM (Note (specNote subst note) body', uds) @@ -688,7 +690,6 @@ specExpr subst (Let bind body) returnSM (foldr Let body' binds', uds) -- Must apply the type substitution to coerceions -specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2) specNote subst note = note \end{code} -- 1.7.10.4