From d386e0d20c6953b7cba4d53538a1782c4aa9980d Mon Sep 17 00:00:00 2001 From: "andy@galois.com" Date: Fri, 29 Dec 2006 07:29:48 +0000 Subject: [PATCH] Adding a GENERATED pragma Adding a {-# GENERATED "SourceFile" SourceSpan #-} 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. --- compiler/deSugar/Coverage.lhs | 13 ++++++++++--- compiler/deSugar/DsMeta.hs | 1 + compiler/hsSyn/HsExpr.lhs | 6 ++++++ compiler/parser/Lexer.x | 3 +++ compiler/parser/Parser.y.pp | 18 +++++++++++++++++- compiler/rename/RnExpr.lhs | 3 +++ compiler/typecheck/TcExpr.lhs | 3 +++ compiler/typecheck/TcHsSyn.lhs | 4 ++++ 8 files changed, 47 insertions(+), 4 deletions(-) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index f888d05..2d967d2 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -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 () diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 58524ea..36b6b4c 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 9bcd06e..bcc3f10 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -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] diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 56d036e..856c298 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index d35d4e2..009eddc 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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 } diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 1c80bc0..996c102 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -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) -> diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index fa0e419..960304b 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -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 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 6e17466..f4e2587 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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 -> -- 1.7.10.4