import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
- splitForAllTy_maybe, isForAllTy, eqType
+ splitForAllTy_maybe, isForAllTy, splitNewType_maybe, eqType
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
go1 other = []
- ok_note (Coerce _ _) = True
- ok_note InlineCall = True
- ok_note other = False
+ ok_note InlineMe = False
+ ok_note other = True
-- Notice that we do not look through __inline_me__
-- This may seem surprising, but consider
-- f = _inline_me (\x -> e)
-- We should have
-- ty = exprType e = exprType e'
--
--- etaExpand deals with for-alls and coerces. For example:
+-- etaExpand deals with for-alls. For example:
-- etaExpand 1 E
--- where E :: forall a. T
--- newtype T = MkT (A -> B)
---
+-- where E :: forall a. a -> a
-- would return
--- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
+-- (/\b. \y::a -> E b y)
+--
+-- It deals with coerces too, though they are now rare
+-- so perhaps the extra code isn't worth it
etaExpand n us expr ty
| n == 0 &&
(us1, us2) = splitUniqSupply us
uniq = uniqFromSupply us1
- ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
- }}
+ ; Nothing ->
+
+ case splitNewType_maybe ty of {
+ Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
+ Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+ }}}
\end{code}
exprArity :: CoreExpr -> Int
exprArity e = go e
where
+ go (Var v) = idArity v
go (Lam x e) | isId x = go e + 1
| otherwise = go e
- go (Note _ e) = go e
+ go (Note n e) = go e
go (App e (Type t)) = go e
go (App f a) | exprIsCheap a = (go f - 1) `max` 0
- -- Important! f (fac x) does not have arity 2,
- -- even if f does!
+ -- NB: exprIsCheap a!
+ -- f (fac x) does not have arity 2,
+ -- even if f has arity 3!
-- NB: `max 0`! (\x y -> f x) has arity 2, even if f is
-- unknown, hence arity 0
- go (Var v) = idArity v
go _ = 0
\end{code}
import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
import Type ( Type, isUnLiftedType, mkFunTys,
- splitForAllTys, splitFunTys, isAlgType
+ splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType
)
import BasicTypes ( Arity, Boxity(..) )
import Var ( Var, isId )
let
val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
wrap_args = tyvars ++ val_args
+ n_args | res_bot = n_arg_tys
+ | otherwise = arity `min` n_arg_tys
+ new_fun_ty | n_args == n_arg_tys = body_ty
+ | otherwise = mkFunTys (drop n_args arg_tys) body_ty
in
mkWWargs new_fun_ty
(arity - n_args)
mkLams wrap_args . wrap_fn_args,
work_fn_args . applyToVars wrap_args,
res_ty)
+
+ | Just rep_ty <- splitNewType_maybe fun_ty,
+ arity >= 0
+ -- The newtype case is for when the function has
+ -- a recursive newtype after the arrow (rare)
+ -- We check for arity >= 0 to avoid looping in the case
+ -- of a function whose type is, in effect, infinite
+ -- [Arity is driven by looking at the term, not just the type.]
+ --
+ -- It's also important when we have a function returning (say) a pair
+ -- wrapped in a recursive newtype, at least if CPR analysis can look
+ -- through such newtypes, which it probably can since they are
+ -- simply coerces.
+ = mkWWargs rep_ty arity demands res_bot one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
+ returnUs (wrap_args,
+ Note (Coerce fun_ty rep_ty) . wrap_fn_args,
+ work_fn_args . Note (Coerce rep_ty fun_ty),
+ res_ty)
+
+ | otherwise
+ = returnUs ([], id, id, fun_ty)
+
where
(tyvars, tau) = splitForAllTys fun_ty
(arg_tys, body_ty) = splitFunTys tau
n_arg_tys = length arg_tys
- n_args | res_bot = n_arg_tys
- | otherwise = arity `min` n_arg_tys
- new_fun_ty | n_args == n_arg_tys = body_ty
- | otherwise = mkFunTys (drop n_args arg_tys) body_ty
-mkWWargs fun_ty arity demands res_bot one_shots
- = returnUs ([], id, id, fun_ty)
applyToVars :: [Var] -> CoreExpr -> CoreExpr
applyToVars vars fn = mkVarApps fn vars
mkNewTyConRep :: TyCon -- The original type constructor
-> Type -- Chosen representation type
-- Find the representation type for this newtype TyCon
--- For a recursive type constructor we give an error thunk,
--- because we never look at the rep in that case
--- (see notes on newypes in types/TypeRep
-
-mkNewTyConRep tc
- | isRecursiveTyCon tc = pprPanic "Attempt to get the rep of newtype" (ppr tc)
- | otherwise = head (dataConOrigArgTys (head (tyConDataCons tc)))
+-- See notes on newypes in types/TypeRep about newtypes.
+mkNewTyConRep tc = head (dataConOrigArgTys (head (tyConDataCons tc)))
\end{code}
SourceType(..), sourceTypeRep,
-- Newtypes
- mkNewTyConApp,
+ splitNewType_maybe,
-- Lifting and boxity
isUnLiftedType, isUnboxedTupleType, isAlgType,
-- Other imports:
import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
-import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
+import {-# SOURCE #-} Subst ( substTyWith )
-- friends:
import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName )
= ASSERT( isSynTyCon syn_tycon )
ASSERT( length tyvars == length tys )
NoteTy (SynNote (TyConApp syn_tycon tys))
- (substTy (mkTyVarSubst tyvars tys) body)
+ (substTyWith tyvars tys body)
where
(tyvars, body) = getSynTyConDefn syn_tycon
\end{code}
applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg),
ptext SLIT("applyTy")
<+> pprType ty <+> pprType arg )
- substTy (mkTyVarSubst [tv] [arg]) ty
+ substTyWith [tv] [arg] ty
applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg)
applyTy other arg = panic "applyTy"
(case mu of
Just u -> UsageTy u
Nothing -> id) $
- substTy (mkTyVarSubst tvs arg_tys) ty
+ substTyWith tvs arg_tys ty
where
(mu, tvs, ty) = split fun_ty arg_tys
sourceTypeRep (IParam n ty) = ty
sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
-- Note the mkTyConApp; the classTyCon might be a newtype!
-sourceTypeRep (NType tc tys) = case newTyConRep tc of
- (tvs, rep_ty) -> substTy (mkTyVarSubst tvs tys) rep_ty
+sourceTypeRep (NType tc tys) = newTypeRep tc tys
-- ToDo: Consider caching this substitution in a NType
-mkNewTyConApp :: TyCon -> [Type] -> SourceType
-mkNewTyConApp tc tys = NType tc tys -- Here is where we might cache the substitution
-
isSourceTy :: Type -> Bool
isSourceTy (NoteTy _ ty) = isSourceTy ty
isSourceTy (UsageTy _ ty) = isSourceTy ty
isSourceTy (SourceTy sty) = True
isSourceTy _ = False
+
+
+splitNewType_maybe :: Type -> Maybe Type
+-- Newtypes that are recursive are reprsented by TyConApp, just
+-- as they always were. Occasionally we want to find their representation type.
+-- NB: remember that in this module, non-recursive newtypes are transparent
+
+splitNewType_maybe ty
+ = case splitTyConApp_maybe ty of
+ Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc )
+ -- The assert should hold because repType should
+ -- only be applied to *types* (of kind *)
+ Just (newTypeRep tc tys)
+ other -> Nothing
+
+-- A local helper function (not exported)
+newTypeRep new_tycon tys = case newTyConRep new_tycon of
+ (tvs, rep_ty) -> substTyWith tvs tys rep_ty
\end{code}
projects / ghc-hetmet.git / commitdiff