Skip to content

GitLab

Commit 283e8585 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Template Haskell: support for INLINE and SPECIALISE pragmas

parent d971d1e8
Hide whitespace changes
Inline Side-by-side
compiler/deSugar/DsMeta.hs
View file @ 283e8585
......@@ -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
compiler/hsSyn/Convert.lhs
View file @ 283e8585
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment