From e3defabc698eb976504f750eee1258fe400a8352 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 20 Jul 2001 16:47:55 +0000 Subject: [PATCH] [project @ 2001-07-20 16:47:55 by simonpj] ------------------------ More newtype squashing ------------------------ Recursive newtypes were confusing the worker/wrapper generator. This is because I originally got rid of opaque newtypes altogether, then put them back for recursive ones only, and forgot to reinstate the cunning stuff in the w/w stuff. (Discovered by Sigbjorn; thanks!) --- ghc/compiler/coreSyn/CoreUtils.lhs | 35 ++++++++++++++++++------------- ghc/compiler/stranal/WwLib.lhs | 34 +++++++++++++++++++++++------- ghc/compiler/typecheck/TcTyClsDecls.lhs | 9 ++------ ghc/compiler/types/Type.lhs | 34 +++++++++++++++++++++--------- 4 files changed, 73 insertions(+), 39 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index d483b82..49c5b7e 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -60,7 +60,7 @@ import IdInfo ( LBVarInfo(..), 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 ) @@ -700,9 +700,8 @@ exprEtaExpandArity e 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) @@ -727,13 +726,14 @@ etaExpand :: Int -- Add this number of value args -- 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 && @@ -761,8 +761,12 @@ etaExpand n us expr ty (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} @@ -792,16 +796,17 @@ And in any case it seems more robust to have exprArity be a bit more intelligent 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} diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 55a269b..994f4b2 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -24,7 +24,7 @@ import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID ) 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 ) @@ -311,6 +311,10 @@ mkWWargs fun_ty arity demands res_bot one_shots 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) @@ -322,17 +326,33 @@ mkWWargs fun_ty arity demands res_bot one_shots 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 diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 382ce38..805c700 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -388,13 +388,8 @@ bogusVrcs = panic "Bogus tycon arg variances" 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} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 973074d..7b5ac35 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -52,7 +52,7 @@ module Type ( SourceType(..), sourceTypeRep, -- Newtypes - mkNewTyConApp, + splitNewType_maybe, -- Lifting and boxity isUnLiftedType, isUnboxedTupleType, isAlgType, @@ -85,7 +85,7 @@ import TypeRep -- 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 ) @@ -363,7 +363,7 @@ mkSynTy syn_tycon tys = 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} @@ -472,7 +472,7 @@ applyTy (NoteTy _ fun) arg = applyTy fun arg 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" @@ -482,7 +482,7 @@ applyTys fun_ty arg_tys (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 @@ -598,18 +598,32 @@ sourceTypeRep :: SourceType -> Type 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} -- 1.7.10.4