X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=5aebd372592d1289b664529a69aaaa8997cf30c5;hp=774c9199e4056401f6731e427098f90a12adf6e3;hb=16b9e80dc14db24509f051f294b5b51943285090;hpb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 774c919..5aebd37 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -13,8 +13,7 @@ have a standard form, namely: \begin{code} module MkId ( - mkDictFunId, mkDefaultMethodId, - mkDictSelId, + mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId, mkDataConIds, mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, @@ -236,9 +235,9 @@ mkDataConIds wrap_name wkr_name data_con wkr_arity = dataConRepArity data_con wkr_info = noCafIdInfo - `setArityInfo` wkr_arity + `setArityInfo` wkr_arity `setStrictnessInfo` Just wkr_sig - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) @@ -271,6 +270,7 @@ mkDataConIds wrap_name wkr_name data_con 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 + `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` newtype_unf id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) newtype_unf = ASSERT2( isVanillaDataCon data_con && @@ -300,6 +300,7 @@ mkDataConIds wrap_name wkr_name data_con `setArityInfo` wrap_arity -- It's important to specify the arity, so that partial -- applications are treated as values + `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` wrap_unf `setStrictnessInfo` Just wrap_sig @@ -317,7 +318,7 @@ mkDataConIds wrap_name wkr_name data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf = mkInlineRule wrap_rhs (Just (length dict_args + length id_args)) + wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs wrap_rhs = mkLams wrap_tvs $ mkLams eq_args $ mkLams dict_args $ mkLams id_args $ @@ -433,19 +434,21 @@ mkDictSelId no_unf name clas base_info = noCafIdInfo `setArityInfo` 1 - `setStrictnessInfo` Just strict_sig + `setStrictnessInfo` Just strict_sig `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding rhs) + else mkImplicitUnfolding rhs) -- In module where class op is defined, we must add -- the unfolding, even though it'll never be inlined -- becuase we use that to generate a top-level binding -- for the ClassOp - info = base_info `setSpecInfo` mkSpecInfo [rule] - `setInlinePragInfo` neverInlinePragma - -- Add a magic BuiltinRule, and never inline it - -- so that the rule is always available to fire. - -- See Note [ClassOp/DFun selection] in TcInstDcls + info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma + -- See Note [Single-method classes] for why alwaysInlinePragma + | otherwise = base_info `setSpecInfo` mkSpecInfo [rule] + `setInlinePragInfo` neverInlinePragma + -- Add a magic BuiltinRule, and never inline it + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in TcInstDcls n_ty_args = length tyvars @@ -491,15 +494,11 @@ mkDictSelId no_unf name clas dictSelRule :: Int -> Arity -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr --- Oh, very clever --- sel_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm +-- Tries to persuade the argument to look like a constructor +-- application, using exprIsConApp_maybe, and then selects +-- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- --- NB: the data constructor has the same number of type and --- coercion args as the selector --- --- This only works for *value* superclasses --- There are no selector functions for equality superclasses dictSelRule val_index n_ty_args n_eq_args id_unf args | (dict_arg : _) <- drop n_ty_args args , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg @@ -838,12 +837,29 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Class -> [Type] -> Id +-- Implements the DFun Superclass Invariant (see TcInstDcls) -mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys - = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo +mkDictFunId dfun_name tvs theta clas tys + = mkExportedLocalVar (DFunId n_silent is_nt) + dfun_name + dfun_ty + vanillaIdInfo where is_nt = isNewTyCon (classTyCon clas) - dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) + (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys + +mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type) +mkDictFunTy tvs theta clas tys + = (length silent_theta, dfun_ty) + where + dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkDictTy clas tys) + silent_theta = filterOut discard $ + substTheta (zipTopTvSubst (classTyVars clas) tys) + (classSCTheta clas) + -- See Note [Silent Superclass Arguments] + discard pred = isEmptyVarSet (tyVarsOfPred pred) + || any (`tcEqPred` pred) theta + -- See the DFun Superclass Invariant in TcInstDcls \end{code} @@ -884,7 +900,8 @@ unsafeCoerceId :: Id unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkForAllTys [argAlphaTyVar,openBetaTyVar] @@ -900,15 +917,16 @@ nullAddrId :: Id -- a way to write this literal in Haskell. nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where - info = noCafIdInfo `setUnfoldingInfo` - mkCompulsoryUnfolding (Lit nullAddrLit) + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) ------------------------------------------------ seqId :: Id -- See Note [seqId magic] seqId = pcMiscPrelId seqName ty info where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs - `setSpecInfo` mkSpecInfo [seq_cast_rule] + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setSpecInfo` mkSpecInfo [seq_cast_rule] ty = mkForAllTys [alphaTyVar,argBetaTyVar]