X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=80885de9907310b3d2323a227644b967dfc02f57;hb=decb48fcf5d82c1abeb8b729dc9c955d0051194a;hp=a425bc3b9ad1b6007199a527764912b74de7f12b;hpb=5815105cd4613a200c3730b76aa342c979f9fcec;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index a425bc3..80885de 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -6,9 +6,16 @@ Utility functions on @Core@ syntax \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 CoreUtils ( -- Construction - mkInlineMe, mkSCC, mkCoerce, + mkInlineMe, mkSCC, mkCoerce, mkCoerceI, bindNonRec, needsCaseBinding, mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, @@ -48,6 +55,7 @@ import SrcLoc import VarSet import VarEnv import Name +import Module #if mingw32_TARGET_OS import Packages #endif @@ -63,7 +71,6 @@ import TyCon import TysWiredIn import CostCentre import BasicTypes -import PackageConfig import Unique import Outputable import DynFlags @@ -194,6 +201,10 @@ mkInlineMe e = Note InlineMe e \begin{code} +mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr +mkCoerceI IdCo e = e +mkCoerceI (ACo co) e = mkCoerce co e + mkCoerce :: Coercion -> CoreExpr -> CoreExpr mkCoerce co (Cast expr co2) = ASSERT(let { (from_ty, _to_ty) = coercionKind co; @@ -259,6 +270,8 @@ mkAltExpr (DataAlt con) args inst_tys = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) mkAltExpr (LitAlt lit) [] [] = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr @@ -658,7 +671,7 @@ dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv"))) dataConRepFSInstPat = dataConInstPat dataConRepArgTys dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv"))) where - dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc + dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc -- Remember to include the existential dictionaries dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys @@ -674,9 +687,13 @@ dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys -- -- co_tvs are intended to be used as binders for coercion args and the kinds -- of these vars have been instantiated by the inst_tys and the ex_tys +-- The co_tvs include both GADT equalities (dcEqSpec) and +-- programmer-specified equalities (dcEqTheta) -- --- arg_ids are indended to be used as binders for value arguments, including --- dicts, and their types have been instantiated with inst_tys and ex_tys +-- arg_ids are indended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both dicts (dcDictTheta) and +-- programmer-specified arguments (after rep-ing) (deRepArgTys) -- -- Example. -- The following constructor T1 @@ -696,16 +713,17 @@ dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us dataConInstPat arg_fun fss uniqs con inst_tys - = (ex_bndrs, co_bndrs, id_bndrs) + = (ex_bndrs, co_bndrs, arg_ids) where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con arg_tys = arg_fun con eq_spec = dataConEqSpec con - eq_preds = eqSpecPreds eq_spec + eq_theta = dataConEqTheta con + eq_preds = eqSpecPreds eq_spec ++ eq_theta n_ex = length ex_tvs - n_co = length eq_spec + n_co = length eq_preds -- split the Uniques and FastStrings (ex_uniqs, uniqs') = splitAt n_ex uniqs @@ -732,14 +750,14 @@ dataConInstPat arg_fun fss uniqs con inst_tys co_kind = substTy subst (mkPredTy eq_pred) -- make value vars, instantiating types - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc - id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan + arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -- Returns (Just (dc, [x1..xn])) if the argument expression is -- a constructor application of the form (dc x1 .. xn) exprIsConApp_maybe (Cast expr co) - = -- Here we do the PushC reduction rule as described in the FC paper + = -- Here we do the KPush reduction rule as described in the FC paper case exprIsConApp_maybe expr of { Nothing -> Nothing ; Just (dc, dc_args) -> @@ -769,17 +787,20 @@ exprIsConApp_maybe (Cast expr co) let tc_arity = tyConArity from_tc - (univ_args, rest1) = splitAt tc_arity dc_args - (ex_args, rest2) = splitAt n_ex_tvs rest1 - (co_args, val_args) = splitAt n_cos rest2 + (univ_args, rest1) = splitAt tc_arity dc_args + (ex_args, rest2) = splitAt n_ex_tvs rest1 + (co_args_spec, rest3) = splitAt n_cos_spec rest2 + (co_args_theta, val_args) = splitAt n_cos_theta rest3 arg_tys = dataConRepArgTys dc dc_univ_tyvars = dataConUnivTyVars dc dc_ex_tyvars = dataConExTyVars dc dc_eq_spec = dataConEqSpec dc + dc_eq_theta = dataConEqTheta dc dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars n_ex_tvs = length dc_ex_tyvars - n_cos = length dc_eq_spec + n_cos_spec = length dc_eq_spec + n_cos_theta = length dc_eq_theta -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co @@ -787,10 +808,15 @@ exprIsConApp_maybe (Cast expr co) theta = zipOpenTvSubst dc_tyvars new_tys -- First we cast the existential coercion arguments - cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv) - `mkTransCoercion` co - `mkTransCoercion` (substTy theta ty) - new_co_args = zipWith cast_co dc_eq_spec co_args + cast_co_spec (tv, ty) co + = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co + cast_co_theta eqPred (Type co) + | (ty1, ty2) <- getEqPredTys eqPred + = Type $ mkSymCoercion (substTy theta ty1) + `mkTransCoercion` co + `mkTransCoercion` (substTy theta ty2) + new_co_args = zipWith cast_co_spec dc_eq_spec co_args_spec ++ + zipWith cast_co_theta dc_eq_theta co_args_theta -- ...and now value arguments new_val_args = zipWith cast_arg arg_tys val_args @@ -993,9 +1019,13 @@ arityType dflags (Lam x e) -- Applications; decrease arity arityType dflags (App f (Type _)) = arityType dflags f -arityType dflags (App f a) = case arityType dflags f of - AFun one_shot xs | exprIsCheap a -> xs - other -> ATop +arityType dflags (App f a) + = case arityType dflags f of + ABot -> ABot -- If function diverges, ignore argument + ATop -> ATop -- No no info about function + AFun one_shot xs + | exprIsCheap a -> xs + | otherwise -> ATop -- Case/Let; keep arity if either the expression is cheap -- or it's a 1-shot lambda @@ -1157,8 +1187,8 @@ eta_expand n us expr ty -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) case splitNewTypeRepCo_maybe ty of { - Just(ty1,co) -> - mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ; + Just(ty1,co) -> mkCoerce (mkSymCoercion co) + (eta_expand n us (mkCoerce co expr) ty1) ; Nothing -> -- We have an expression of arity > 0, but its type isn't a function