From: Manuel M T Chakravarty Date: Fri, 4 Aug 2006 19:23:02 +0000 (+0000) Subject: Massive patch for the first months work adding System FC to GHC #4 X-Git-Tag: After_FC_branch_merge~176 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f94350a049d2a1c2b2f1aa25c62dfe20a541c049 Massive patch for the first months work adding System FC to GHC #4 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. --- diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 105d248..c8f35ea 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -14,19 +14,19 @@ import CoreUtils( exprType, exprIsHNF, etaExpand, exprArity, exprOkForSpeculatio import CoreFVs ( exprFreeVars ) import CoreLint ( endPass ) import CoreSyn -import Type ( Type, applyTy, splitFunTy_maybe, - isUnLiftedType, isUnboxedTupleType, seqType ) +import Type ( Type, applyTy, + splitFunTy_maybe, isUnLiftedType, isUnboxedTupleType, seqType ) +import Coercion ( coercionKind ) import TyCon ( TyCon, tyConDataCons ) import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) ) import Var ( Var, Id, setVarUnique ) import VarSet import VarEnv -import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType, - isFCallId, isGlobalId, - isLocalId, hasNoBinding, idNewStrictness, +import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, + isFCallId, isGlobalId, isLocalId, hasNoBinding, idNewStrictness, isPrimOpId_maybe ) -import DataCon ( isVanillaDataCon, dataConWorkId ) +import DataCon ( dataConWorkId ) import PrimOp ( PrimOp( DataToTagOp ) ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec @@ -48,7 +48,8 @@ The goal of this pass is to prepare for code generation. 1. Saturate constructor and primop applications. -2. Convert to A-normal form: +2. Convert to A-normal form; that is, function arguments + are always variables. * Use case for strict arguments: f E ==> case E of x -> f x @@ -338,6 +339,7 @@ exprIsTrivial (Lit lit) = True exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e exprIsTrivial (Note (SCC _) e) = False exprIsTrivial (Note _ e) = exprIsTrivial e +exprIsTrivial (Cast e co) = exprIsTrivial e exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body exprIsTrivial other = False @@ -387,6 +389,10 @@ corePrepExprFloat env (Note other_note expr) = corePrepExprFloat env expr `thenUs` \ (floats, expr') -> returnUs (floats, Note other_note expr') +corePrepExprFloat env (Cast expr co) + = corePrepExprFloat env expr `thenUs` \ (floats, expr') -> + returnUs (floats, Cast expr' co) + corePrepExprFloat env expr@(Lam _ _) = cloneBndrs env bndrs `thenUs` \ (env', bndrs') -> corePrepAnExpr env' body `thenUs` \ body' -> @@ -406,10 +412,7 @@ corePrepExprFloat env (Case scrut bndr ty alts) returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts') where sat_alt env (con, bs, rhs) - = let - env1 = setGadt env con - in - cloneBndrs env1 bs `thenUs` \ (env2, bs') -> + = cloneBndrs env bs `thenUs` \ (env2, bs') -> corePrepAnExpr env2 rhs `thenUs` \ rhs1 -> deLam rhs1 `thenUs` \ rhs2 -> returnUs (con, bs', rhs2) @@ -475,11 +478,11 @@ corePrepExprFloat env expr@(App _ _) -- Here, we can't evaluate the arg strictly, because this -- partial application might be seq'd - - collect_args (Note (Coerce ty1 ty2) fun) depth - = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) -> - returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss) - + collect_args (Cast fun co) depth + = let (_ty1,ty2) = coercionKind co in + collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) -> + returnUs (Cast fun' co, hd, ty2, floats, ss) + collect_args (Note note fun) depth | ignore_note note -- Drop these notes altogether -- They aren't used by the code generator @@ -675,6 +678,9 @@ etaExpandRhs bndr rhs -- --------------------------------------------------------------------------- deLam :: CoreExpr -> UniqSM CoreExpr +-- Takes an expression that may be a lambda, +-- and returns one that definitely isn't: +-- (\x.e) ==> let f = \x.e in f deLam expr = deLamFloat expr `thenUs` \ (floats, expr) -> mkBinds floats expr @@ -689,6 +695,10 @@ deLamFloat (Note n expr) deLamFloat expr `thenUs` \ (floats, expr') -> returnUs (floats, Note n expr') +deLamFloat (Cast e co) + = deLamFloat e `thenUs` \ (floats, e') -> + returnUs (floats, Cast e' co) + deLamFloat expr | null bndrs = returnUs (emptyFloats, expr) | otherwise @@ -703,7 +713,8 @@ deLamFloat expr -- Why try eta reduction? Hasn't the simplifier already done eta? -- But the simplifier only eta reduces if that leaves something -- trivial (like f, or f Int). But for deLam it would be enough to --- get to a partial application, like (map f). +-- get to a partial application: +-- \xs. map f xs ==> map f tryEta bndrs expr@(App _ _) | ok_to_eta_reduce f && @@ -780,38 +791,18 @@ onceDem = RhsDemand False True -- used at most once -- --------------------------------------------------------------------------- data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids - Bool -- True <=> inside a GADT case; see Note [GADT] - --- Note [GADT] --- --- Be careful with cloning inside GADTs. For example, --- /\a. \f::a. \x::T a. case x of { T -> f True; ... } --- The case on x may refine the type of f to be a function type. --- Without this type refinement, exprType (f True) may simply fail, --- which is bad. --- --- Solution: remember when we are inside a potentially-type-refining case, --- and in that situation use the type from the old occurrence --- when looking up occurrences emptyCorePrepEnv :: CorePrepEnv -emptyCorePrepEnv = CPE emptyVarEnv False +emptyCorePrepEnv = CPE emptyVarEnv extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv -extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt +extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id') lookupCorePrepEnv :: CorePrepEnv -> Id -> Id --- See Note [GADT] above -lookupCorePrepEnv (CPE env gadt) id +lookupCorePrepEnv (CPE env) id = case lookupVarEnv env id of - Nothing -> id - Just id' | gadt -> setIdType id' (idType id) - | otherwise -> id' - -setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv -setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True -setGadt env other = env - + Nothing -> id + Just id' -> id' ------------------------------------------------------------------------------ -- Cloning binders diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 6f13740..7b80eac 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -11,8 +11,7 @@ module CoreTidy ( import CoreSyn import CoreUtils ( exprArity ) -import Unify ( coreRefineTys ) -import DataCon ( DataCon, isVanillaDataCon ) +import DataCon ( DataCon ) import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique, idType, setIdType ) import IdInfo ( setArityInfo, vanillaIdInfo, @@ -57,11 +56,12 @@ tidyBind env (Rec prs) ------------ Expressions -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr -tidyExpr env (Var v) = Var (tidyVarOcc env v) -tidyExpr env (Type ty) = Type (tidyType env ty) -tidyExpr env (Lit lit) = Lit lit -tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) -tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e) +tidyExpr env (Var v) = Var (tidyVarOcc env v) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Lit lit) = Lit lit +tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) +tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyType env co) tidyExpr env (Let b e) = tidyBind env b =: \ (env', b') -> @@ -77,42 +77,11 @@ tidyExpr env (Lam b e) Lam b (tidyExpr env' e) ------------ Case alternatives -------------- -tidyAlt case_bndr env (DataAlt con, vs, rhs) - | not (isVanillaDataCon con) -- GADT case - = tidyBndrs env tvs =: \ (env1, tvs') -> - let - env2 = refineTidyEnv env1 con tvs' scrut_ty - in - tidyBndrs env2 ids =: \ (env3, ids') -> - (DataAlt con, tvs' ++ ids', tidyExpr env3 rhs) - where - (tvs, ids) = span isTyVar vs - scrut_ty = idType case_bndr - tidyAlt case_bndr env (con, vs, rhs) = tidyBndrs env vs =: \ (env', vs) -> (con, vs, tidyExpr env' rhs) -refineTidyEnv :: TidyEnv -> DataCon -> [TyVar] -> Type -> TidyEnv --- Refine the TidyEnv in the light of the type refinement from coreRefineTys -refineTidyEnv tidy_env@(occ_env, var_env) con tvs scrut_ty - = case coreRefineTys con tvs scrut_ty of - Nothing -> tidy_env - Just (tv_subst, all_bound_here) - | all_bound_here -- Local type refinement only - -> tidy_env - | otherwise -- Apply the refining subst to the tidy env - -- This ensures that occurences have the most refined type - -- And that means that exprType will work right everywhere - -> (occ_env, mapVarEnv (refine subst) var_env) - where - subst = mkOpenTvSubst tv_subst - where - refine subst var | isId var = setIdType var (substTy subst (idType var)) - | otherwise = var - ------------ Notes -------------- -tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2) tidyNote env note = note ------------ Rules --------------