From 283e858564bb7979e59dcf00e852c2039aff231c Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Tue, 24 Mar 2009 23:29:40 +0000 Subject: [PATCH] Template Haskell: support for INLINE and SPECIALISE pragmas --- compiler/deSugar/DsMeta.hs | 131 ++++++++++++++++++++++++++++++++++++++------ compiler/hsSyn/Convert.lhs | 60 +++++++++++++++++--- 2 files changed, 168 insertions(+), 23 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 82dffd7..5c3486a 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -426,14 +426,64 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc -rep_sig _ = return [] +rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc +rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc +rep_sig _ = return [] + +rep_proto :: Located Name -> LHsType Name -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] +rep_proto nm ty loc + = do { nm1 <- lookupLOcc nm + ; ty1 <- repLTy ty + ; sig <- repProto nm1 ty1 + ; return [(loc, sig)] + } + +rep_inline :: Located Name -> InlineSpec -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] +rep_inline nm ispec loc + = do { nm1 <- lookupLOcc nm + ; (_, ispec1) <- rep_InlineSpec ispec + ; pragma <- repPragInl nm1 ispec1 + ; return [(loc, pragma)] + } + +rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan + -> DsM [(SrcSpan, Core TH.DecQ)] +rep_specialise nm ty ispec loc + = do { nm1 <- lookupLOcc nm + ; ty1 <- repLTy ty + ; (hasSpec, ispec1) <- rep_InlineSpec ispec + ; pragma <- if hasSpec + then repPragSpecInl nm1 ty1 ispec1 + else repPragSpec nm1 ty1 + ; return [(loc, pragma)] + } -rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] -rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; - ty1 <- repLTy ty ; - sig <- repProto nm1 ty1 ; - return [(loc, sig)] } +-- extract all the information needed to build a TH.InlineSpec +-- +rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ) +rep_InlineSpec (Inline (InlinePragma activation match) inline) + | Nothing <- activation1 + = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1 + | Just (flag, phase) <- activation1 + = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase + | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec" + where + match1 = coreBool (rep_RuleMatchInfo match) + activation1 = rep_Activation activation + inline1 = coreBool inline + + rep_RuleMatchInfo FunLike = False + rep_RuleMatchInfo ConLike = True + + rep_Activation NeverActive = Nothing + rep_Activation AlwaysActive = Nothing + rep_Activation (ActiveBefore phase) = Just (coreBool False, + MkC $ mkIntExprInt phase) + rep_Activation (ActiveAfter phase) = Just (coreBool True, + MkC $ mkIntExprInt phase) ------------------------------------------------------- @@ -1313,14 +1363,37 @@ repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs) repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds] -repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ) -repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds] +repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] + -> Core [TH.FunDep] -> Core [TH.DecQ] + -> DsM (Core TH.DecQ) +repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) + = rep2 classDName [cxt, cls, tvs, fds, ds] + +repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ) +repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec] + +repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty] + +repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ + -> DsM (Core TH.DecQ) +repPragSpecInl (MkC nm) (MkC ty) (MkC ispec) + = rep2 pragSpecInlDName [nm, ty, ispec] repFamily :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.Name] -> DsM (Core TH.DecQ) repFamily (MkC flav) (MkC nm) (MkC tvs) = rep2 familyDName [flav, nm, tvs] +repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ) +repInlineSpecNoPhase (MkC inline) (MkC conlike) + = rep2 inlineSpecNoPhaseName [inline, conlike] + +repInlineSpecPhase :: Core Bool -> 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] + repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] @@ -1471,6 +1544,12 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) coreStringLit :: String -> DsM (Core String) coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } +------------ Bool, Literals & Variables ------------------- + +coreBool :: Bool -> Core Bool +coreBool False = MkC $ mkConApp falseDataCon [] +coreBool True = MkC $ mkConApp trueDataCon [] + coreIntLit :: Int -> DsM (Core Int) coreIntLit i = return (MkC (mkIntExprInt i)) @@ -1533,8 +1612,9 @@ templateHaskellNames = [ bindSName, letSName, noBindSName, parSName, -- Dec funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, sigDName, forImpDName, familyDName, dataInstDName, - newtypeInstDName, tySynInstDName, + classDName, instanceDName, sigDName, forImpDName, + pragInlDName, pragSpecDName, pragSpecInlDName, + familyDName, dataInstDName, newtypeInstDName, tySynInstDName, -- Cxt cxtName, -- Pred @@ -1556,6 +1636,8 @@ templateHaskellNames = [ unsafeName, safeName, threadsafeName, + -- InlineSpec + inlineSpecNoPhaseName, inlineSpecPhaseName, -- FunDep funDepName, -- FamFlavour @@ -1714,8 +1796,9 @@ parSName = libFun (fsLit "parS") parSIdKey -- data Dec = ... funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, - instanceDName, sigDName, forImpDName, familyDName, dataInstDName, - newtypeInstDName, tySynInstDName :: Name + instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, + pragSpecInlDName, familyDName, dataInstDName, newtypeInstDName, + tySynInstDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey @@ -1725,6 +1808,9 @@ classDName = libFun (fsLit "classD") classDIdKey instanceDName = libFun (fsLit "instanceD") instanceDIdKey sigDName = libFun (fsLit "sigD") sigDIdKey forImpDName = libFun (fsLit "forImpD") forImpDIdKey +pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey +pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey +pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey familyDName = libFun (fsLit "familyD") familyDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey @@ -1781,6 +1867,11 @@ unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey +-- data InlineSpec = ... +inlineSpecNoPhaseName, inlineSpecPhaseName :: Name +inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey +inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey + -- data FunDep = ... funDepName :: Name funDepName = libFun (fsLit "funDep") funDepIdKey @@ -1959,8 +2050,9 @@ parSIdKey = mkPreludeMiscIdUnique 271 -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, - classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, familyDIdKey, - dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique + classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, + pragSpecDIdKey, pragSpecInlDIdKey, familyDIdKey, dataInstDIdKey, + newtypeInstDIdKey, tySynInstDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 272 valDIdKey = mkPreludeMiscIdUnique 273 dataDIdKey = mkPreludeMiscIdUnique 274 @@ -1970,6 +2062,9 @@ classDIdKey = mkPreludeMiscIdUnique 277 instanceDIdKey = mkPreludeMiscIdUnique 278 sigDIdKey = mkPreludeMiscIdUnique 279 forImpDIdKey = mkPreludeMiscIdUnique 297 +pragInlDIdKey = mkPreludeMiscIdUnique 348 +pragSpecDIdKey = mkPreludeMiscIdUnique 349 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 352 familyDIdKey = mkPreludeMiscIdUnique 340 dataInstDIdKey = mkPreludeMiscIdUnique 341 newtypeInstDIdKey = mkPreludeMiscIdUnique 342 @@ -2026,6 +2121,11 @@ unsafeIdKey = mkPreludeMiscIdUnique 305 safeIdKey = mkPreludeMiscIdUnique 306 threadsafeIdKey = mkPreludeMiscIdUnique 307 +-- data InlineSpec = +inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique +inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350 +inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351 + -- data FunDep = ... funDepIdKey :: Unique funDepIdKey = mkPreludeMiscIdUnique 320 @@ -2039,4 +2139,3 @@ dataFamIdKey = mkPreludeMiscIdUnique 345 quoteExpKey, quotePatKey :: Unique quoteExpKey = mkPreludeMiscIdUnique 321 quotePatKey = mkPreludeMiscIdUnique 322 - diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index a6b24b6..60080ee 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -20,7 +20,7 @@ import OccName import SrcLoc import Type import TysWiredIn -import BasicTypes +import BasicTypes as Hs import ForeignCall import Char import List @@ -163,7 +163,15 @@ cvtTop (InstanceD ctxt ty decs) isFamInstD (TySynInstD _ _ _) = True isFamInstD _ = False -cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' } +cvtTop (ForeignD ford) + = do { ford' <- cvtForD ford + ; returnL $ ForD ford' + } + +cvtTop (PragmaD prag) + = do { prag' <- cvtPragmaD prag + ; returnL $ Hs.SigD prag' + } cvtTop (FamilyD flav tc tvs) = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs @@ -370,6 +378,35 @@ lex_ccall_impent xs = case span is_valid xs of where is_valid :: Char -> Bool is_valid c = isAscii c && (isAlphaNum c || c `elem` "._") +------------------------------------------ +-- Pragmas +------------------------------------------ + +cvtPragmaD :: Pragma -> CvtM (Sig RdrName) +cvtPragmaD (InlineP nm ispec) + = do { nm' <- vNameL nm + ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) + } +cvtPragmaD (SpecialiseP nm ty opt_ispec) + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) + } + +cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlineSpec +cvtInlineSpec Nothing + = defaultInlineSpec +cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) + = mkInlineSpec opt_activation' matchinfo inline + where + matchinfo = cvtRuleMatchInfo conlike + opt_activation' = fmap cvtActivation opt_activation + + cvtRuleMatchInfo False = FunLike + cvtRuleMatchInfo True = ConLike + + cvtActivation (False, phase) = ActiveBefore phase + cvtActivation (True , phase) = ActiveAfter phase --------------------------------------------------- -- Declarations @@ -377,22 +414,31 @@ lex_ccall_impent xs = case span is_valid xs of cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName) cvtDecs [] = return EmptyLocalBinds -cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds +cvtDecs ds = do { (binds, sigs) <- cvtBindsAndSigs ds ; return (HsValBinds (ValBindsIn binds sigs)) } cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName]) cvtBindsAndSigs ds - = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs + = do { binds' <- mapM cvtBind binds + ; sigs' <- mapM cvtSig sigs ; return (listToBag binds', sigs') } where (sigs, binds) = partition is_sig ds - is_sig (TH.SigD _ _) = True - is_sig _ = False + is_sig (TH.SigD _ _) = True + is_sig (TH.PragmaD _) = True + is_sig _ = False cvtSig :: TH.Dec -> CvtM (LSig RdrName) cvtSig (TH.SigD nm ty) - = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') } + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; returnL (Hs.TypeSig nm' ty') + } +cvtSig (TH.PragmaD prag) + = do { prag' <- cvtPragmaD prag + ; returnL prag' + } cvtSig _ = panic "Convert.cvtSig: Signature expected" cvtBind :: TH.Dec -> CvtM (LHsBind RdrName) -- 1.7.10.4