)
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
-import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType,
- PredType(..),
- mkTopTvSubst, substTyVar )
+import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes,
+ newTyConInstRhs, mkTopTvSubst, substTyVar, substTy )
import TcGadt ( gadtRefine, refineType, emptyRefinement )
import HsBinds ( ExprCoFn(..), isIdCoercion )
-import Coercion ( mkSymCoercion, mkUnsafeCoercion,
- splitNewTypeRepCo_maybe, isEqPred )
+import Coercion ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
mkTyConApp, mkTyVarTys, mkClassPred, isPredTy,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, tcEqType,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
)
-import CoreUtils ( exprType, dataConOrigInstPat )
+import CoreUtils ( exprType, dataConOrigInstPat, mkCoerce )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
- tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
- newTyConCo, tyConArity )
+ tyConStupidTheta, isProductTyCon, isDataTyCon,
+ isRecursiveTyCon, tyConFamily_maybe, newTyConCo )
import Class ( Class, classTyCon, classSelIds )
-import Var ( Id, TyVar, Var, setIdType, mkCoVar, mkWildCoVar )
+import Var ( Id, TyVar, Var, setIdType )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
-import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..),
- mkSysTvName )
+import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..))
import OccName ( mkOccNameFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
-import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars,
+import DataCon ( DataCon, DataConIds(..), dataConTyCon,
+ dataConUnivTyVars, dataConInstTys,
dataConFieldLabels, dataConRepArity, dataConResTys,
dataConRepArgTys, dataConRepType, dataConFullSig,
- dataConSig, dataConStrictMarks, dataConExStricts,
+ dataConStrictMarks, dataConExStricts,
splitProductType, isVanillaDataCon, dataConFieldType,
- dataConInstOrigArgTys, deepSplitProductType
+ deepSplitProductType,
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
- mkTemplateLocal, idName, mkWildId
+ mkTemplateLocal, idName
)
import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
setArityInfo, setSpecInfo, setCafInfo,
import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
+import Maybe ( fromJust )
import Maybes
import PrelNames
import Util ( dropList, isSingleton )
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon
- = NewDC nt_wrap_id
+ = DCIds Nothing nt_work_id -- Newtype, only has a worker
| any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
|| not (null eq_spec)
- = AlgDC (Just alg_wrap_id) wrk_id
+ || isInst
+ = DCIds (Just alg_wrap_id) wrk_id
| otherwise -- Algebraic, no wrapper
- = AlgDC Nothing wrk_id
+ = DCIds Nothing wrk_id
where
- (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con
- tycon = dataConTyCon data_con
+ (univ_tvs, ex_tvs, eq_spec,
+ theta, orig_arg_tys) = dataConFullSig data_con
+ tycon = dataConTyCon data_con
+ (isInst, instTys, familyTyCon) =
+ case dataConInstTys data_con of
+ Nothing -> (False, [] , familyTyCon)
+ Just instTys -> (True , instTys, familyTyCon)
+ where
+ familyTyCon = fromJust $ tyConFamily_maybe tycon
+ -- this is defined whenever `isInst'
----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
subst = mkTopTvSubst eq_spec
dict_tys = mkPredTys theta
result_ty_args = map (substTyVar subst) univ_tvs
- result_ty = mkTyConApp tycon result_ty_args
+ familyArgs = map (substTy subst) instTys
+ result_ty = if isInst
+ then mkTyConApp familyTyCon familyArgs -- instance con
+ else mkTyConApp tycon result_ty_args -- ordinary con
wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
mkFunTys orig_arg_tys $ result_ty
-- NB: watch out here if you allow user-written equality
-- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
- ----------- Wrappers for newtypes --------------
- nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info
- nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
+ ----------- Workers for newtypes --------------
+ nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
+ nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setUnfoldingInfo` newtype_unf
newtype_unf = ASSERT( isVanillaDataCon data_con &&
(zip (dict_args ++ id_args) all_strict_marks)
i3 []
- con_app i rep_ids = Var wrk_id `mkTyApps` result_ty_args
+ con_app _ rep_ids = Var wrk_id `mkTyApps` result_ty_args
`mkVarApps` ex_tvs
`mkTyApps` map snd eq_spec
`mkVarApps` reverse rep_ids
Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
MarkedUnboxed
- -> unboxProduct i (Var arg) (idType arg) the_body result_ty
+ -> unboxProduct i (Var arg) (idType arg) the_body
where
the_body i con_args = body i (reverse con_args ++ rep_args)
-- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
-- ids, we get (modulo int passing)
--
--- case (e `cast` (sym CoT)) `cast` (sym CoS) of
+-- case (e `cast` CoT) `cast` CoS of
-- PairInt a b -> body [a,b]
--
-- The Ints passed around are just for creating fresh locals
-unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> Type -> CoreExpr
-unboxProduct i arg arg_ty body res_ty
+unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
+unboxProduct i arg arg_ty body
= result
where
- result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs
+ result = mkUnpackCase the_id arg con_args boxing_con rhs
(_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
([the_id], i') = mkLocals i [arg_ty]
(con_args, i'') = mkLocals i' tys
rhs = body i'' con_args
-mkUnpackCase :: Id -> CoreExpr -> Type -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
-- (mkUnpackCase x e args Con body)
-- returns
-- case (e `cast` ...) of bndr { Con args -> body }
--
-- the type of the bndr passed in is irrelevent
-mkUnpackCase bndr arg arg_ty unpk_args boxing_con body
+mkUnpackCase bndr arg unpk_args boxing_con body
= Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
where
(cast_arg, bndr_ty) = go (idType bndr) arg
go ty arg
- | res@(tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
+ | (tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
, isNewTyCon tycon && not (isRecursiveTyCon tycon)
= go (newTyConInstRhs tycon tycon_args)
(unwrapNewTypeBody tycon tycon_args arg)
where
stricts = dataConExStricts con ++ dataConStrictMarks con
- go [] stricts us = ([], [])
+ go [] _stricts _us = ([], [])
-- Type variable case
go (arg:args) stricts us
-- The wrapper for the data constructor for a newtype looks like this:
-- newtype T a = MkT (a,Int)
-- MkT :: forall a. (a,Int) -> T a
--- MkT = /\a. \(x:(a,Int)). x `cast` CoT a
+-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
-- where CoT is the coercion TyCon assoicated with the newtype
--
-- The call (wrapNewTypeBody T [a] e) returns the
-- body of the wrapper, namely
--- e `cast` CoT [a]
+-- e `cast` (CoT [a])
--
-- 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
| Just co_con <- newTyConCo tycon
- = Cast result_expr (mkTyConApp co_con args)
+ = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
| otherwise
= result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
| Just co_con <- newTyConCo tycon
- = Cast result_expr (mkSymCoercion (mkTyConApp co_con args))
+ = mkCoerce (mkTyConApp co_con args) result_expr
| otherwise
= result_expr
projects / ghc-hetmet.git / blobdiff