Commit c94408e5 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

newtype fixes, coercions for non-recursive newtypes now optional

Mon Sep 18 14:24:27 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * newtype fixes, coercions for non-recursive newtypes now optional
  Sat Aug  5 21:19:58 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * newtype fixes, coercions for non-recursive newtypes now optional
    Fri Jul  7 06:11:48 EDT 2006  kevind@bu.edu
parent 3e83dfb2
......@@ -709,35 +709,23 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-- body of the wrapper, namely
-- e `cast` CoT [a]
--
-- For non-recursive newtypes, GHC currently treats them like type
-- synonyms, so no cast is necessary. This function is the only
-- place in the compiler that generates
-- If a coercion constructor is prodivided in the newtype, then we use
-- it, otherwise the wrap/unwrap are both no-ops
--
wrapNewTypeBody tycon args result_expr
-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
= Cast result_expr co
-- | otherwise
-- = result_expr
where
co = mkTyConApp (newTyConCo tycon) args
| Just co_con <- newTyConCo tycon
= Cast result_expr (mkTyConApp co_con args)
| otherwise
= result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
= Cast result_expr sym_co
-- | otherwise
-- = result_expr
where
sym_co = mkSymCoercion co
co = mkTyConApp (newTyConCo tycon) args
-- Old Definition of mkNewTypeBody
-- Used for both wrapping and unwrapping
--mkNewTypeBody tycon result_ty result_expr
-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
-- = Note (Coerce result_ty (exprType result_expr)) result_expr
-- | otherwise -- Normal case
-- = result_expr
| Just co_con <- newTyConCo tycon
= Cast result_expr (mkSymCoercion (mkTyConApp co_con args))
| otherwise
= result_expr
\end{code}
......
......@@ -38,7 +38,7 @@ import Type ( Type, tyVarsOfType, coreEqType,
extendTvSubst, composeTvSubst, substTyVarBndr, isInScope,
getTvSubstEnv, getTvInScope, mkTyVarTy )
import Coercion ( Coercion, coercionKind, coercionKindTyConApp )
import TyCon ( isPrimTyCon )
import TyCon ( isPrimTyCon, isNewTyCon )
import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
import StaticFlags ( opt_PprStyle_Debug )
import DynFlags ( DynFlags, DynFlag(..), dopt )
......@@ -497,6 +497,7 @@ lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) =
lit_ty = literalType lit
lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
| isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
| Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
= addLoc (CaseAlt alt) $ lintBinders args $ \ args ->
......@@ -801,6 +802,13 @@ mkBadAltMsg scrut_ty alt
text "Scrutinee type:" <+> ppr scrut_ty,
text "Alternative:" <+> pprCoreAlt alt ]
mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
mkNewTyDataConAltMsg scrut_ty alt
= vcat [ text "Data alternative for newtype datacon",
text "Scrutinee type:" <+> ppr scrut_ty,
text "Alternative:" <+> pprCoreAlt alt ]
------------------------------------------------------
-- Other error messages
......
......@@ -50,11 +50,13 @@ import StaticFlags ( opt_RuntimeTypes )
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
import TyCon ( isNewTyCon )
import Coercion ( Coercion )
import Name ( Name )
import OccName ( OccName )
import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConWorkId, dataConTag )
import DataCon ( DataCon, dataConWorkId, dataConTag, dataConTyCon,
dataConWrapId )
import BasicTypes ( Activation )
import FastString
import Outputable
......@@ -440,7 +442,9 @@ mkLets :: [Bind b] -> Expr b -> Expr b
mkLams :: [b] -> Expr b -> Expr b
mkLit lit = Lit lit
mkConApp con args = pprTrace "mkConApp" (ppr con) $ mkApps (Var (dataConWorkId con)) args
mkConApp con args
| isNewTyCon (dataConTyCon con) = mkApps (Var (dataConWrapId con)) args
| otherwise = mkApps (Var (dataConWorkId con)) args
mkLams binders body = foldr Lam body binders
mkLets binds body = foldr Let body binds
......
......@@ -179,7 +179,6 @@ make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind k
| isLiftedTypeKind k = C.Klifted
| isUnliftedTypeKind k = C.Kunlifted
-- | isUnboxedTypeKind k = C.Kunboxed Fix me
| isOpenTypeKind k = C.Kopen
make_kind _ = error "MkExternalCore died: make_kind"
......
......@@ -25,7 +25,7 @@ import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity )
import Outputable
import SrcLoc ( Located(..), SrcSpan, unLoc )
import Util ( sortLe )
import Var ( TyVar, DictId, Id )
import Var ( TyVar, DictId, Id, Var )
import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
\end{code}
......
......@@ -84,7 +84,9 @@ mkNewTyConRhs tycon_name tycon con
= do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty
; return (NewTyCon { data_con = con,
nt_co = co_tycon,
nt_co = Just co_tycon,
-- Coreview looks through newtypes with a Nothing
-- for nt_co, or uses explicit coercions otherwise
nt_rhs = rhs_ty,
nt_etad_rhs = eta_reduce tvs rhs_ty,
nt_rep = mkNewTyConRep tycon rhs_ty }) }
......@@ -116,9 +118,8 @@ mkNewTyConRep :: TyCon -- The original type constructor
-- Remember that the representation type is the *ultimate* representation
-- type, looking through other newtypes.
--
-- The non-recursive newtypes are easy, because they look transparent
-- to splitTyConApp_maybe, but recursive ones really are represented as
-- TyConApps (see TypeRep).
-- splitTyConApp_maybe no longer looks through newtypes, so we must
-- deal explicitly with this case
--
-- The trick is to to deal correctly with recursive newtypes
-- such as newtype T = MkT T
......@@ -133,10 +134,11 @@ mkNewTyConRep tc rhs_ty
= case splitTyConApp_maybe rep_ty of
Just (tc, tys)
| tc `elem` tcs -> unitTy -- Recursive loop
| isNewTyCon tc -> ASSERT( isRecursiveTyCon tc )
-- Non-recursive ones have been
-- dealt with by splitTyConApp_maybe
go (tc:tcs) (substTyWith tvs tys rhs_ty)
| isNewTyCon tc ->
if isRecursiveTyCon tc then
go (tc:tcs) (substTyWith tvs tys rhs_ty)
else
go tcs (head tys)
where
(tvs, rhs_ty) = newTyConRhs tc
......
......@@ -640,8 +640,9 @@ implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++
implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
-- For newtypes, add the implicit coercion tycon
implicitNewCoTyCon tc | isNewTyCon tc = [ATyCon (newTyConCo tc)]
| otherwise = []
implicitNewCoTyCon tc
| isNewTyCon tc, Just co_con <- newTyConCo tc = [ATyCon co_con]
| otherwise = []
extras_plus thing = thing : implicitTyThings thing
......
......@@ -50,7 +50,7 @@ import OccName ( mkOccNameFS, tcName, mkTyVarOcc )
import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon,
PrimRep(..) )
import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
unliftedTypeKind, unboxedTypeKind,
unliftedTypeKind,
liftedTypeKind, openTypeKind,
Kind, mkArrowKinds,
TyThing(..)
......@@ -187,17 +187,13 @@ pcPrimTyCon name arity rep
= mkPrimTyCon name kind arity rep
where
kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind
result_kind = case rep of
PtrRep -> unliftedTypeKind
_other -> unboxedTypeKind
result_kind = unliftedTypeKind
pcPrimTyCon0 :: Name -> PrimRep -> TyCon
pcPrimTyCon0 name rep
= mkPrimTyCon name result_kind 0 rep
where
result_kind = case rep of
PtrRep -> unliftedTypeKind
_other -> unboxedTypeKind
result_kind = unliftedTypeKind
charPrimTy = mkTyConTy charPrimTyCon
charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep
......
......@@ -1144,7 +1144,8 @@ mkDataConAlt :: DataCon -> [OutType] -> InExpr -> SimplM InAlt
-- Make a data-constructor alternative to replace the DEFAULT case
-- NB: there's something a bit bogus here, because we put OutTypes into an InAlt
mkDataConAlt con inst_tys rhs
= do { tv_uniqs <- getUniquesSmpl
= ASSERT(not (isNewTyCon (dataConTyCon con)))
do { tv_uniqs <- getUniquesSmpl
; arg_uniqs <- getUniquesSmpl
; let tv_bndrs = zipWith mk_tv_bndr (dataConExTyVars con) tv_uniqs
arg_tys = dataConInstArgTys con (inst_tys ++ mkTyVarTys tv_bndrs)
......@@ -1491,7 +1492,7 @@ mkCase1 scrut case_bndr ty alts -- Identity case
| isNewTyCon (dataConTyCon con)
= wrapNewTypeBody (dataConTyCon con) arg_tys (varToCoreExpr $ head args)
| otherwise
= pprTrace "mkCase1" (ppr con) $ mkConApp con (arg_ty_exprs ++ varsToCoreExprs args)
= mkConApp con (arg_ty_exprs ++ varsToCoreExprs args)
identity_rhs (LitAlt lit) _ = Lit lit
identity_rhs DEFAULT _ = Var case_bndr
......
......@@ -611,7 +611,6 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
-- means that we can avoid tests in exprIsConApp, for example.
-- This is important: if exprIsConApp says 'yes' for a recursive
-- thing, then we can get into an infinite loop
-- If the unfolding is a value, the demand info may
-- go pear-shaped, so we nuke it. Example:
-- let x = (a,b) in
......@@ -1520,6 +1519,7 @@ simplDefault :: SimplEnv
simplDefault env case_bndr' imposs_cons cont Nothing
= return [] -- No default branch
simplDefault env case_bndr' imposs_cons cont (Just rhs)
| -- This branch handles the case where we are
-- scrutinisng an algebraic data type
......@@ -1560,7 +1560,7 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
| otherwise
| otherwise
= simplify_default imposs_cons
where
cant_match tys data_con = not (dataConCanMatch data_con tys)
......
......@@ -171,9 +171,10 @@ dmdAnal sigs dmd (Cast e co)
(dmd_ty, e') = dmdAnal sigs dmd' e
to_co = snd (coercionKind co)
dmd'
| Just (tc, args) <- splitTyConApp_maybe to_co
, isRecursiveTyCon tc = evalDmd
| otherwise = dmd
-- | Just (tc, args) <- splitTyConApp_maybe to_co
= evalDmd
-- , isRecursiveTyCon tc = evalDmd
-- | otherwise = dmd
-- This coerce usually arises from a recursive
-- newtype, and we don't want to look inside them
-- for exactly the same reason that we don't look
......
......@@ -240,7 +240,6 @@ mkWWargs fun_ty demands one_shots
\ e -> Cast (wrap_fn_args e) co,
\ e -> work_fn_args (Cast e (mkSymCoercion co)),
res_ty)
| notNull demands
= getUniquesUs `thenUs` \ wrap_uniqs ->
let
......
......@@ -71,6 +71,7 @@ import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSub
import Unify ( tcMatchTys )
import Module ( modulePackageId )
import {- Kind parts of -} Type ( isSubKind )
import Coercion ( isEqPred )
import HscTypes ( ExternalPackageState(..), HscEnv(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConStupidTheta, dataConName,
......@@ -80,7 +81,7 @@ import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
isInternalName, setNameUnique )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind, setIdType )
import Var ( Var, TyVar, tyVarKind, setIdType, mkTyVar )
import VarEnv ( TidyEnv, emptyTidyEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
......
......@@ -42,7 +42,8 @@ import NameSet ( duDefs )
import Type ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
isEnumerationTyCon, isRecursiveTyCon, TyCon
isEnumerationTyCon, isRecursiveTyCon, TyCon, isNewTyCon,
newTyConCo
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
isUnLiftedType, mkClassPred, tyVarsOfType,
......@@ -367,7 +368,7 @@ makeDerivEqns overlap_flag tycl_decls
traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_`
new_dfun_name clas tycon `thenM` \ dfun_name ->
returnM (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name,
iBinds = NewTypeDerived rep_tys }))
iBinds = NewTypeDerived (newTyConCo tycon) rep_tys }))
| std_class gla_exts clas
= mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route
......
......@@ -565,7 +565,9 @@ data InstBindings
[LSig Name] -- User pragmas recorded for generating
-- specialised instances
| NewTypeDerived -- Used for deriving instances of newtypes, where the
| NewTypeDerived
(Maybe TyCon) -- maybe a coercion for the newtype
-- Used for deriving instances of newtypes, where the
[Type] -- witness dictionary is identical to the argument
-- dictionary. Hence no bindings, no pragmas
-- The [Type] are the representation types
......@@ -576,7 +578,7 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
where
details (VanillaInst b _) = pprLHsBinds b
details (NewTypeDerived _) = text "Derived from the representation type"
details (NewTypeDerived _ _) = text "Derived from the representation type"
simpleInstInfoClsTy :: InstInfo -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
......
......@@ -523,6 +523,44 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
mapM tc_method_bind meth_infos `thenM` \ meth_binds_s ->
returnM (meth_ids, unionManyBags meth_binds_s)
v v v v v v v
*************
-- Derived newtype instances
tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
avail_insts op_items (NewTypeDerived maybe_co rep_tys)
= getInstLoc origin `thenM` \ inst_loc ->
mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) ->
tcSimplifyCheck
(ptext SLIT("newtype derived instance"))
inst_tyvars' avail_insts rhs_insts `thenM` \ lie_binds ->
-- I don't think we have to do the checkSigTyVars thing
returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds)
where
do_one inst_loc (sel_id, _)
= -- The binding is like "op @ NewTy = op @ RepTy"
-- Make the *binder*, like in mkMethodBind
tcInstClassOp inst_loc sel_id inst_tys' `thenM` \ meth_inst ->
-- Make the *occurrence on the rhs*
tcInstClassOp inst_loc sel_id rep_tys' `thenM` \ rhs_inst ->
let
meth_id = instToId meth_inst
in
return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst)
-- Instantiate rep_tys with the relevant type variables
-- This looks a bit odd, because inst_tyvars' are the skolemised version
-- of the type variables in the instance declaration; but rep_tys doesn't
-- have the skolemised version, so we substitute them in here
rep_tys' = substTys subst rep_tys
subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars')
^ ^ ^ ^ ^ ^ ^
\end{code}
......
......@@ -43,7 +43,8 @@ import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon ),
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName )
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
isNewTyCon )
import DataCon ( DataCon, dataConUserType, dataConName,
dataConFieldLabels, dataConTyCon, dataConAllTyVars,
dataConFieldType, dataConResTys )
......@@ -598,7 +599,9 @@ argStrictness unbox_strict tycon bangs arg_tys
-- We attempt to unbox/unpack a strict field when either:
-- (i) The field is marked '!!', or
-- (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
--
-- We have turned off unboxing of newtypes because coercions make unboxing
-- and reboxing more complicated
chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark
chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
= case bang of
......@@ -609,7 +612,7 @@ chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang
where
can_unbox = case splitTyConApp_maybe arg_ty of
Nothing -> False
Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) &&
Just (arg_tycon, _) -> not (isNewTyCon arg_tycon) && not (isRecursiveTyCon tycon) &&
isProductTyCon arg_tycon
\end{code}
......
......@@ -89,7 +89,7 @@ module TcType (
--------------------------------
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
unliftedTypeKind, liftedTypeKind, unboxedTypeKind, argTypeKind,
unliftedTypeKind, liftedTypeKind, argTypeKind,
openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind,
isSubArgTypeKind, isSubKind, defaultKind,
......@@ -135,7 +135,6 @@ import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tyVarsOfTheta, Kind, PredType(..), KindVar,
ThetaType, isUnliftedTypeKind, unliftedTypeKind,
-- ??? unboxedTypeKind,
argTypeKind,
liftedTypeKind, openTypeKind, mkArrowKind,
tySuperKind, isLiftedTypeKind,
......
......@@ -20,7 +20,7 @@ module TyCon(
isHiBootTyCon, isSuperKindTyCon,
isCoercionTyCon_maybe, isCoercionTyCon,
tcExpandTyCon_maybe, coreExpandTyCon_maybe, stgExpandTyCon_maybe,
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
makeTyConAbstract, isAbstractTyCon,
......@@ -199,8 +199,9 @@ data AlgTyConRhs
-- = the representation type of the tycon
-- The free tyvars of this type are the tyConTyVars
nt_co :: TyCon, -- The coercion used to create the newtype
nt_co :: Maybe TyCon, -- The coercion used to create the newtype
-- from the representation
-- optional for non-recursive newtypes
-- See Note [Newtype coercions]
nt_etad_rhs :: ([TyVar], Type) ,
......@@ -514,9 +515,10 @@ isProductTyCon :: TyCon -> Bool
-- has *one* constructor,
-- is *not* existential
-- but
-- may be DataType or NewType,
-- may be DataType, NewType
-- may be unboxed or not,
-- may be recursive or not
--
isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
DataTyCon{ data_cons = [data_con] }
-> isVanillaDataCon data_con
......@@ -606,24 +608,15 @@ tcExpandTyCon_maybe other_tycon tys = Nothing
---------------
-- For the *Core* view, we expand synonyms only as well
{-
coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive, -- Not recursive
algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys
algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys
= case etad_rhs of -- Don't do this in the pattern match, lest we accidentally
-- match the etad_rhs of a *recursive* newtype
(tvs,rhs) -> expand tvs rhs tys
-}
coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys
---------------
-- For the *STG* view, we expand synonyms *and* non-recursive newtypes
stgExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive, -- Not recursive
algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys
= case etad_rhs of -- Don't do this in the pattern match, lest we accidentally
-- match the etad_rhs of a *recursive* newtype
(tvs,rhs) -> expand tvs rhs tys
coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys
stgExpandTyCon_maybe tycon tys = coreExpandTyCon_maybe tycon tys
----------------
expand :: [TyVar] -> Type -- Template
......@@ -682,7 +675,7 @@ newTyConRep :: TyCon -> ([TyVar], Type)
newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
newTyConCo :: TyCon -> TyCon
newTyConCo :: TyCon -> Maybe TyCon
newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
......
......@@ -47,7 +47,7 @@ module Type (
splitTyConApp_maybe, splitTyConApp,
splitNewTyConApp_maybe, splitNewTyConApp,
repType, typePrimRep, coreView, tcView, stgView, kindView,
repType, typePrimRep, coreView, tcView, kindView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls,
......@@ -123,7 +123,6 @@ import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
isAlgTyCon, tyConArity, isSuperKindTyCon,
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
stgExpandTyCon_maybe,
tyConKind, PrimRep(..), tyConPrimRep, tyConUnique,
isCoercionTyCon_maybe, isCoercionTyCon
)
......@@ -177,19 +176,6 @@ coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc
-- partially-applied type constructor; indeed, usually will!
coreView ty = Nothing
{-# INLINE stgView #-}
stgView :: Type -> Maybe Type
-- When generating STG from Core it is important that we look through newtypes
-- but for the rest of Core we are just using coercions. This does just what
-- coreView USED to do.
stgView (NoteTy _ ty) = Just ty
stgView (PredTy p) = Just (predTypeRep p)
stgView (TyConApp tc tys) | Just (tenv, rhs, tys') <- stgExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-- Its important to use mkAppTys, rather than (foldl AppTy),
-- because the function part might well return a
-- partially-applied type constructor; indeed, usually will!
stgView ty = Nothing
-----------------------------------------------
......
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