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,
import VarSet
import VarEnv
import Name
+import Module
#if mingw32_TARGET_OS
import Packages
#endif
import TysWiredIn
import CostCentre
import BasicTypes
-import PackageConfig
import Unique
import Outputable
import DynFlags
\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;
= 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
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
--
-- 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
-- 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
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) ->
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
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
-- 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
-- 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
projects / ghc-hetmet.git / blobdiff