From 23cd13dac2d7c10266aa924df56268f4d7f1eca9 Mon Sep 17 00:00:00 2001 From: Mikhail Vorozhtsov Date: Tue, 7 Feb 2012 23:25:39 +0700 Subject: [PATCH] TH: INLINABLE pragma support. --- compiler/deSugar/DsMeta.hs | 55 ++++++++++++++++++++++++++++++++------------ compiler/hsSyn/Convert.lhs | 11 ++++---- 2 files changed, 46 insertions(+), 20 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 4105a9e..9833bb6 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -44,7 +44,8 @@ import PrelNames -- OccName.varName we do this by removing varName from the import of -- OccName above, making a qualified instance of OccName and using -- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName ) +import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, + dataName ) import Module import Id @@ -532,22 +533,26 @@ rep_specialise nm ty ispec loc ; return [(loc, pragma)] } +repInline :: InlineSpec -> DsM (Core TH.Inline) +repInline NoInline = dataCon noInlineDataConName +repInline Inline = dataCon inlineDataConName +repInline Inlinable = dataCon inlinableDataConName +repInline spec = notHandled "repInline" (ppr spec) + -- Extract all the information needed to build a TH.InlinePrag -- rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma -> DsM (Core TH.InlineSpecQ) rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline }) | Just (flag, phase) <- activation1 - = repInlineSpecPhase inline1 match1 flag phase + = do { inline1 <- repInline inline + ; repInlineSpecPhase inline1 match1 flag phase } | otherwise - = repInlineSpecNoPhase inline1 match1 + = do { inline1 <- repInline inline + ; repInlineSpecNoPhase inline1 match1 } where match1 = coreBool (rep_RuleMatchInfo match) activation1 = rep_Activation activation - inline1 = case inline of - Inline -> coreBool True - _other -> coreBool False - -- We have no representation for Inlinable rep_RuleMatchInfo FunLike = False rep_RuleMatchInfo ConLike = True @@ -1285,6 +1290,10 @@ rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) rep2 n xs = do { id <- dsLookupGlobalId n ; return (MkC (foldl App (Var id) xs)) } +dataCon :: Name -> DsM (Core a) +dataCon n = do { id <- dsLookupDataCon n + ; return $ MkC $ mkConApp id [] } + -- Then we make "repConstructors" which use the phantom types for each of the -- smart constructors of the Meta.Meta datatypes. @@ -1511,11 +1520,12 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) = rep2 familyKindDName [flav, nm, tvs, ki] -repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ) +repInlineSpecNoPhase :: Core TH.Inline -> Core Bool + -> DsM (Core TH.InlineSpecQ) repInlineSpecNoPhase (MkC inline) (MkC conlike) = rep2 inlineSpecNoPhaseName [inline, conlike] -repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int +repInlineSpecPhase :: Core TH.Inline -> Core Bool -> Core Bool -> Core Int -> DsM (Core TH.InlineSpecQ) repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase) = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase] @@ -1791,6 +1801,8 @@ templateHaskellNames = [ unsafeName, safeName, interruptibleName, + -- Inline + noInlineDataConName, inlineDataConName, inlinableDataConName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, -- FunDep @@ -1818,12 +1830,13 @@ qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") mkTHModule :: FastString -> Module mkTHModule m = mkModule thPackageId (mkModuleNameFS m) -libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name -libFun = mk_known_key_name OccName.varName thLib -libTc = mk_known_key_name OccName.tcName thLib -thFun = mk_known_key_name OccName.varName thSyn -thTc = mk_known_key_name OccName.tcName thSyn -qqFun = mk_known_key_name OccName.varName qqLib +libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name +libFun = mk_known_key_name OccName.varName thLib +libTc = mk_known_key_name OccName.tcName thLib +thFun = mk_known_key_name OccName.varName thSyn +thTc = mk_known_key_name OccName.tcName thSyn +thCon = mk_known_key_name OccName.dataName thSyn +qqFun = mk_known_key_name OccName.varName qqLib -------------------- TH.Syntax ----------------------- qTyConName, nameTyConName, fieldExpTyConName, patTyConName, @@ -2044,6 +2057,12 @@ unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey +-- data Inline = ... +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name +noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey +inlineDataConName = thCon (fsLit "Inline") inlineDataConKey +inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey + -- data InlineSpec = ... inlineSpecNoPhaseName, inlineSpecPhaseName :: Name inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey @@ -2326,6 +2345,12 @@ unsafeIdKey = mkPreludeMiscIdUnique 400 safeIdKey = mkPreludeMiscIdUnique 401 interruptibleIdKey = mkPreludeMiscIdUnique 403 +-- data Inline = ... +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique +noInlineDataConKey = mkPreludeDataConUnique 40 +inlineDataConKey = mkPreludeDataConUnique 41 +inlinableDataConKey = mkPreludeDataConUnique 42 + -- data InlineSpec = inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 404 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 5318c5b..3c27232 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -426,12 +426,13 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) cvtRuleMatchInfo False = FunLike cvtRuleMatchInfo True = ConLike - inl_spec | inline = Inline - | otherwise = NoInline - -- Currently we have no way to say Inlinable + inl_spec = case inline of + TH.NoInline -> Hs.NoInline + TH.Inline -> Hs.Inline + TH.Inlinable -> Hs.Inlinable - cvtActivation Nothing | inline = AlwaysActive - | otherwise = NeverActive + cvtActivation Nothing | inline == TH.NoInline = NeverActive + | otherwise = AlwaysActive cvtActivation (Just (False, phase)) = ActiveBefore phase cvtActivation (Just (True , phase)) = ActiveAfter phase -- 1.7.9