Commit d386e0d2 authored by andy@galois.com's avatar andy@galois.com

Adding a GENERATED pragma

Adding a {-# GENERATED "SourceFile" SourceSpan #-} <expr> pragma.
This will be used to generate coverage for tool generated (or quoted) code.
The pragma states the the expression was generated/quoted from the stated
source file and source span.
parent 654a1ba1
......@@ -39,6 +39,7 @@ import MkId
import PrimOp
import BasicTypes ( RecFlag(..), Activation(NeverActive), Boxity(..) )
import Data.List ( isSuffixOf )
import FastString ( unpackFS )
import System.Time (ClockTime(..))
import System.Directory (getModificationTime)
......@@ -258,6 +259,11 @@ addTickHsExpr (ArithSeq ty arith_seq) =
liftM2 ArithSeq
(return ty)
(addTickArithSeqInfo arith_seq)
addTickHsExpr (HsTickPragma (file,(l1,c1),(l2,c2)) (L pos e0)) = do
e1 <- addTickHsExpr e0
fn <- allocTickBox (ExternalBox (unpackFS file) (P l1 c1 l2 c2)) pos
let (L _ e2) = fn $ L pos e1
return $ e2
addTickHsExpr (PArrSeq {}) = error "addTickHsExpr: PArrSeq "
addTickHsExpr (HsSCC {}) = error "addTickHsExpr: HsSCC "
addTickHsExpr (HsCoreAnn {}) = error "addTickHsExpr: HsCoreAnn "
......@@ -555,12 +561,13 @@ data BoxLabel = ExpBox
| AltBox
| TopLevelBox [String]
| LocalBox [String]
-- | UserBox (Maybe String)
| GuardBinBox Bool
| CondBinBox Bool
| QualBinBox Bool
-- | PreludeBinBox String Bool
-- | UserBinBox (Maybe String) Bool
| ExternalBox String HpcPos
-- ^The position was generated from the named file/module,
-- with the stated position (inside the named file/module).
-- The HpcPos inside this MixEntry refers to the generated Haskell location.
deriving (Read, Show)
mixCreate :: String -> String -> Mix -> IO ()
......
......@@ -567,6 +567,7 @@ repE (HsSpliceE (HsSplice n _))
repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
repE e = notHandled "Expression form" (ppr e)
......
......@@ -213,6 +213,10 @@ data HsExpr id
Int -- module-local tick number for False
(LHsExpr id) -- sub-expression
| HsTickPragma -- A pragma introduced tick
(FastString,(Int,Int),(Int,Int)) -- external span for this tick
(LHsExpr id)
---------------------------------------
-- The following are commands, not expressions proper
......@@ -412,6 +416,8 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
ppr tickIdFalse,
ptext SLIT(">("),
ppr exp,ptext SLIT(")")]
ppr_expr (HsTickPragma externalSrcLoc exp)
= hcat [ptext SLIT("tickpragma<"), ppr externalSrcLoc,ptext SLIT(">("), ppr exp,ptext SLIT(")")]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg]
......
......@@ -233,6 +233,8 @@ $white_no_nl+ ;
"{-#" $whitechar* (DEPRECATED|deprecated)
{ token ITdeprecated_prag }
"{-#" $whitechar* (SCC|scc) { token ITscc_prag }
"{-#" $whitechar* (GENERATED|generated)
{ token ITgenerated_prag }
"{-#" $whitechar* (CORE|core) { token ITcore_prag }
"{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
......@@ -432,6 +434,7 @@ data Token
| ITdeprecated_prag
| ITline_prag
| ITscc_prag
| ITgenerated_prag
| ITcore_prag -- hdaume: core annotations
| ITunpack_prag
| ITclose_prag
......
......@@ -31,7 +31,7 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
SrcSpan, combineLocs, srcLocFile,
mkSrcLoc, mkSrcSpan )
import Module
import StaticFlags ( opt_SccProfilingOn )
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
Activation(..), defaultInlineSpec )
......@@ -223,6 +223,7 @@ incorrect.
'{-# RULES' { L _ ITrules_prag }
'{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
'{-# SCC' { L _ ITscc_prag }
'{-# GENERATED' { L _ ITgenerated_prag }
'{-# DEPRECATED' { L _ ITdeprecated_prag }
'{-# UNPACK' { L _ ITunpack_prag }
'#-}' { L _ ITclose_prag }
......@@ -1264,6 +1265,9 @@ exp10 :: { LHsExpr RdrName }
| scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2
else HsPar $2 }
| hpc_annot exp { LL $ if opt_Hpc
then HsTickPragma (unLoc $1) $2
else HsPar $2 }
| 'proc' aexp '->' exp
{% checkPattern $2 >>= \ p ->
......@@ -1279,6 +1283,18 @@ scc_annot :: { Located FastString }
: '_scc_' STRING { LL $ getSTRING $2 }
| '{-# SCC' STRING '#-}' { LL $ getSTRING $2 }
hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
: '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
{ LL $ (getSTRING $2
,( fromInteger $ getINTEGER $3
, fromInteger $ getINTEGER $5
)
,( fromInteger $ getINTEGER $7
, fromInteger $ getINTEGER $9
)
)
}
fexp :: { LHsExpr RdrName }
: fexp aexp { LL $ HsApp $1 $2 }
| aexp { $1 }
......
......@@ -179,6 +179,9 @@ rnExpr (HsCoreAnn ann expr)
rnExpr (HsSCC lbl expr)
= rnLExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsSCC lbl expr', fvs_expr)
rnExpr (HsTickPragma info expr)
= rnLExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsTickPragma info expr', fvs_expr)
rnExpr (HsLam matches)
= rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
......
......@@ -129,6 +129,9 @@ tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
; returnM (HsSCC lbl expr') }
tcExpr (HsTickPragma info expr) res_ty
= do { expr' <- tcMonoExpr expr res_ty
; returnM (HsTickPragma info expr') }
tcExpr (HsCoreAnn lbl expr) res_ty -- hdaume: core annotation
= do { expr' <- tcMonoExpr expr res_ty
......
......@@ -489,6 +489,10 @@ zonkExpr env (HsSCC lbl expr)
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (HsSCC lbl new_expr)
zonkExpr env (HsTickPragma info expr)
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (HsTickPragma info new_expr)
-- hdaume: core annotations
zonkExpr env (HsCoreAnn lbl expr)
= zonkLExpr env expr `thenM` \ new_expr ->
......
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