Commit e3defabc authored by simonpj's avatar simonpj
Browse files

[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!)
parent 0fa26afe
......@@ -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}
......
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment