-- 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}
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 )
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 ->
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
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
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
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"
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}
= 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 }) }
-- 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
= 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
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
import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon,
PrimRep(..) )
import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
- unliftedTypeKind, unboxedTypeKind,
+ unliftedTypeKind,
liftedTypeKind, openTypeKind,
Kind, mkArrowKinds,
TyThing(..)
= 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
-- 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)
| 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
-- 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
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
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)
(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
\ e -> Cast (wrap_fn_args e) co,
\ e -> work_fn_args (Cast e (mkSymCoercion co)),
res_ty)
-
| notNull demands
= getUniquesUs `thenUs` \ wrap_uniqs ->
let
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,
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 )
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,
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
[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
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
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}
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 )
-- 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
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}
--------------------------------
-- 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,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tyVarsOfTheta, Kind, PredType(..), KindVar,
ThetaType, isUnliftedTypeKind, unliftedTypeKind,
--- ??? unboxedTypeKind,
argTypeKind,
liftedTypeKind, openTypeKind, mkArrowKind,
tySuperKind, isLiftedTypeKind,
isHiBootTyCon, isSuperKindTyCon,
isCoercionTyCon_maybe, isCoercionTyCon,
- tcExpandTyCon_maybe, coreExpandTyCon_maybe, stgExpandTyCon_maybe,
+ tcExpandTyCon_maybe, coreExpandTyCon_maybe,
makeTyConAbstract, isAbstractTyCon,
-- = 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) ,
-- 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
---------------
-- 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
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)
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,
isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
isAlgTyCon, tyConArity, isSuperKindTyCon,
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
- stgExpandTyCon_maybe,
tyConKind, PrimRep(..), tyConPrimRep, tyConUnique,
isCoercionTyCon_maybe, isCoercionTyCon
)
-- 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
-----------------------------------------------
projects / ghc-hetmet.git / commitdiff