From c94408e522e5af3b79a5beadc7e6d15cee553ee7 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 16:53:13 +0000 Subject: [PATCH] newtype fixes, coercions for non-recursive newtypes now optional Mon Sep 18 14:24:27 EDT 2006 Manuel M T Chakravarty * newtype fixes, coercions for non-recursive newtypes now optional Sat Aug 5 21:19:58 EDT 2006 Manuel M T Chakravarty * newtype fixes, coercions for non-recursive newtypes now optional Fri Jul 7 06:11:48 EDT 2006 kevind@bu.edu --- compiler/basicTypes/MkId.lhs | 36 +++++++++++---------------------- compiler/coreSyn/CoreLint.lhs | 10 ++++++++- compiler/coreSyn/CoreSyn.lhs | 8 ++++++-- compiler/coreSyn/MkExternalCore.lhs | 1 - compiler/hsSyn/HsBinds.lhs | 2 +- compiler/iface/BuildTyCl.lhs | 18 +++++++++-------- compiler/main/HscTypes.lhs | 5 +++-- compiler/prelude/TysPrim.lhs | 10 +++------ compiler/simplCore/SimplUtils.lhs | 5 +++-- compiler/simplCore/Simplify.lhs | 4 ++-- compiler/stranal/DmdAnal.lhs | 7 ++++--- compiler/stranal/WwLib.lhs | 1 - compiler/typecheck/Inst.lhs | 3 ++- compiler/typecheck/TcDeriv.lhs | 5 +++-- compiler/typecheck/TcEnv.lhs | 6 ++++-- compiler/typecheck/TcInstDcls.lhs | 38 +++++++++++++++++++++++++++++++++++ compiler/typecheck/TcTyClsDecls.lhs | 9 ++++++--- compiler/typecheck/TcType.lhs | 3 +-- compiler/types/TyCon.lhs | 25 +++++++++-------------- compiler/types/Type.lhs | 16 +-------------- 20 files changed, 117 insertions(+), 95 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 33482fe..d1d7a02 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -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} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 11b4e3d..788c4b4 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -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 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index a108945..29b1ce4 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -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 diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index c8885f7..8181754 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -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" diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 8f9279e..f3a0d0b 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -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} diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index e4c392b..ad58028 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 26d6fab..2c8780c 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -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 diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 4cb3ef7..4b6832a 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -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 diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 4a61341..235cdfe 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -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 diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index efc59d1..85b4b49 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -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) diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 3fc8477..6adda66 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -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 diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index f3af6f0..c4e78eb 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -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 diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 8971320..98fe3e9 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -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 ) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 46e702c..fdf78cf 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -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 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 19deca9..936ec5b 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index cf27ead..3e55844 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -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} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 3cf6145..a23c6ba 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -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} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 06eb0dc..84d944a 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -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, diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index fab15fc..99afac9 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -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) diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index ccabfb7..4614395 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -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 ----------------------------------------------- -- 1.7.10.4