X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=inline;f=compiler%2FbasicTypes%2FMkId.lhs;h=6af89b74a0a7ed781ec07e9eb6a1ce20136d2dda;hb=80c89b80c355b2aaebcd53330e6c6170c3f05aca;hp=fdc4300aedbb7b94d192c2dc25277cc446ed21c7;hpb=37a594c2ef06b4655444e2e5a1b0fb386ff9f950;p=ghc-hetmet.git diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index fdc4300..6af89b7 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -46,43 +46,41 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, ) 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, @@ -95,6 +93,7 @@ import NewDemand ( mkStrictSig, DmdResult(..), import DmdAnal ( dmdAnalTopRhs ) import CoreSyn import Unique ( mkBuiltinUnique, mkPrimOpIdUnique ) +import Maybe ( fromJust ) import Maybes import PrelNames import Util ( dropList, isSingleton ) @@ -195,17 +194,26 @@ Notice that 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 @@ -215,7 +223,10 @@ mkDataConIds wrap_name wkr_name data_con 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 @@ -259,9 +270,9 @@ mkDataConIds wrap_name wkr_name data_con -- 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 && @@ -305,7 +316,7 @@ mkDataConIds wrap_name wkr_name 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 @@ -329,7 +340,7 @@ mkDataConIds wrap_name wkr_name data_con 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) @@ -595,32 +606,32 @@ mkRecordSelId tycon field_label -- 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) @@ -692,7 +703,7 @@ mkReboxingAlt us con args rhs where stricts = dataConExStricts con ++ dataConStrictMarks con - go [] stricts us = ([], []) + go [] _stricts _us = ([], []) -- Type variable case go (arg:args) stricts us @@ -785,26 +796,26 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- 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