Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,260
Issues
4,260
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
398
Merge Requests
398
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
283e8585
Commit
283e8585
authored
Mar 24, 2009
by
chak@cse.unsw.edu.au.
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Template Haskell: support for INLINE and SPECIALISE pragmas
parent
d971d1e8
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
168 additions
and
23 deletions
+168
-23
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMeta.hs
+115
-16
compiler/hsSyn/Convert.lhs
compiler/hsSyn/Convert.lhs
+53
-7
No files found.
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)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment