From 56b5a8b862d4eaeeaa941dd53e3d1009bdeadc0d Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 20 Feb 2003 18:33:55 +0000 Subject: [PATCH] [project @ 2003-02-20 18:33:50 by simonpj] ------------------------------------- Add Core Notes and the {-# CORE #-} pragma ------------------------------------- This is an idea of Hal Daume's. The key point is that Notes in Core are augmented thus: data Note = SCC CostCentre | ... | CoreNote String -- NEW These notes can be injected via a Haskell-source pragma: f x = ({-# CORE "foo" #-} show) ({-# CORE "bar" #-} x) This wraps a (Note (CoreNote "foo")) around the 'show' variable, and a similar note around the argument to 'show'. These notes are basically ignored by GHC, but are emitted into External Core, where they may convey useful information. Exactly how code involving these notes is munged by the simplifier isn't very well defined. We'll see how it pans out. Meanwhile the impact on the rest of the compiler is minimal. --- ghc/compiler/coreSyn/CorePrep.lhs | 9 +++++---- ghc/compiler/coreSyn/CoreSyn.lhs | 3 +++ ghc/compiler/coreSyn/CoreUtils.lhs | 2 ++ ghc/compiler/coreSyn/MkExternalCore.lhs | 1 + ghc/compiler/coreSyn/PprCore.lhs | 6 ++++++ ghc/compiler/deSugar/DsExpr.lhs | 7 +++++++ ghc/compiler/deSugar/DsMeta.hs | 1 + ghc/compiler/hsSyn/HsCore.lhs | 4 ++++ ghc/compiler/hsSyn/HsExpr.lhs | 3 +++ ghc/compiler/main/BinIface.hs | 7 ++++++- ghc/compiler/parser/Lex.lhs | 2 ++ ghc/compiler/parser/Parser.y | 5 ++++- ghc/compiler/rename/RnExpr.lhs | 4 ++++ ghc/compiler/rename/RnSource.lhs | 2 +- ghc/compiler/simplCore/FloatIn.lhs | 3 +++ ghc/compiler/simplCore/Simplify.lhs | 4 ++++ ghc/compiler/typecheck/TcClassDcl.lhs | 1 - ghc/compiler/typecheck/TcExpr.lhs | 3 ++- ghc/compiler/typecheck/TcHsSyn.lhs | 5 +++++ 19 files changed, 63 insertions(+), 9 deletions(-) diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 7ab6894..8f4a89d 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -454,10 +454,11 @@ corePrepExprFloat env expr@(App _ _) where ty = exprType fun - ignore_note InlineCall = True - ignore_note InlineMe = True - ignore_note _other = False - -- we don't ignore SCCs, since they require some code generation + ignore_note (CoreNote _) = True + ignore_note InlineCall = True + ignore_note InlineMe = True + ignore_note _other = False + -- We don't ignore SCCs, since they require some code generation ------------------------------------------------------------------------------ -- Building the saturated syntax diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 12f750f..edee0dd 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -109,6 +109,8 @@ data Note | InlineMe -- Instructs simplifer to treat the enclosed expression -- as very small, and inline it at its call sites + | CoreNote String -- A generic core annotation, propagated but not used by GHC + -- NOTE: we also treat expressions wrapped in InlineMe as -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable) -- What this means is that we obediently inline even things that don't @@ -549,6 +551,7 @@ seqExprs [] = () seqExprs (e:es) = seqExpr e `seq` seqExprs es seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2 +seqNote (CoreNote s) = s `seq` () seqNote other = () seqBndr b = b `seq` () diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 537f85b..0c22380 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -1045,6 +1045,7 @@ eqExpr e1 e2 eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2 eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2 eq_note env InlineCall InlineCall = True + eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2 eq_note env other1 other2 = False \end{code} @@ -1075,6 +1076,7 @@ noteSize (SCC cc) = cc `seq` 1 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1 noteSize InlineCall = 1 noteSize InlineMe = 1 +noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations varSize :: Var -> Int varSize b | isTyVar b = 1 diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index 2b32348..ee9064c 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -146,6 +146,7 @@ make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts make_exp (Note (SCC cc) e) = C.Note "SCC" (make_exp e) -- temporary make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e) make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e) +make_exp (Note (CoreNote s) e) = C.Note s (make_exp e) -- hdaume: core annotations make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e) make_exp _ = error "MkExternalCore died: make_exp" diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 7c9494e..7e67271 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -44,6 +44,7 @@ import PprType ( pprParendType, pprType, pprTyVarBndr ) import BasicTypes ( tupleParens ) import Util ( lengthIs ) import Outputable +import FastString ( mkFastString ) \end{code} %************************************************************************ @@ -235,6 +236,11 @@ ppr_expr add_par (Note InlineCall expr) ppr_expr add_par (Note InlineMe expr) = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr +ppr_expr add_par (Note (CoreNote s) expr) + = add_par $ + sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)], + pprParendExpr expr] + pprCoreAlt (con, args, rhs) = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 6ae0d0c..3a31d90 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -241,6 +241,13 @@ dsExpr (HsSCC cc expr) getModuleDs `thenDs` \ mod_name -> returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr) + +-- hdaume: core annotation + +dsExpr (HsCoreAnn fs expr) + = dsExpr expr `thenDs` \ core_expr -> + returnDs (Note (CoreNote $ unpackFS fs) core_expr) + -- special case to handle unboxed tuple patterns. dsExpr (HsCase discrim matches src_loc) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 0b58d3d..045afbe 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -488,6 +488,7 @@ repE (ArithSeqIn aseq) = ds3 <- repE e3 repFromThenTo ds1 ds2 ds3 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" +repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__" repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" repE (HsBracketOut _ _) = diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index e73c4a4..86f657b 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -76,6 +76,7 @@ data UfNote name = UfSCC CostCentre | UfCoerce (HsType name) | UfInlineCall | UfInlineMe + | UfCoreNote String type UfAlt name = (UfConAlt name, [name], UfExpr name) @@ -124,6 +125,7 @@ toUfNote (SCC cc) = UfSCC cc toUfNote (Coerce t1 _) = UfCoerce (toHsType t1) toUfNote InlineCall = UfInlineCall toUfNote InlineMe = UfInlineMe +toUfNote (CoreNote s) = UfCoreNote s --------------------- toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r) @@ -252,6 +254,7 @@ instance Outputable name => Outputable (UfNote name) where ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty ppr UfInlineCall = ptext SLIT("__inline_call") ppr UfInlineMe = ptext SLIT("__inline_me") + ppr (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s) instance Outputable name => Outputable (UfConAlt name) where ppr UfDefault = text "__DEFAULT" @@ -353,6 +356,7 @@ eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2) eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2 eq_ufNote UfInlineCall UfInlineCall = True eq_ufNote UfInlineMe UfInlineMe = True + eq_ufNote (UfCoreNote s1) (UfCoreNote s2) = s1==s2 eq_ufNote _ _ = False eq_ufExpr env _ _ = False diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 0cdd2b2..70888b9 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -157,6 +157,9 @@ data HsExpr id | HsSCC FastString -- "set cost centre" (_scc_) annotation (HsExpr id) -- expr whose cost is to be measured + + | HsCoreAnn FastString -- hdaume: core annotation + (HsExpr id) -- MetaHaskell Extensions | HsBracket (HsBracket id) SrcLoc diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs index 2e582bb..e489fb2 100644 --- a/ghc/compiler/main/BinIface.hs +++ b/ghc/compiler/main/BinIface.hs @@ -940,6 +940,9 @@ instance (Binary name) => Binary (UfNote name) where putByte bh 2 put_ bh UfInlineMe = do putByte bh 3 + put_ bh (UfCoreNote s) = do + putByte bh 4 + put_ bh s get bh = do h <- getByte bh case h of @@ -948,7 +951,9 @@ instance (Binary name) => Binary (UfNote name) where 1 -> do ab <- get bh return (UfCoerce ab) 2 -> do return UfInlineCall - _ -> do return UfInlineMe + 3 -> do return UfInlineMe + _ -> do ac <- get bh + return (UfCoreNote ac) instance (Binary name) => Binary (BangType name) where put_ bh (BangType aa ab) = do diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 9ae21ef..2c78f39 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -133,6 +133,7 @@ data Token | ITdeprecated_prag | ITline_prag | ITscc_prag + | ITcore_prag -- hdaume: core annotations | ITclose_prag | ITdotdot -- reserved symbols @@ -230,6 +231,7 @@ pragmaKeywordsFM = listToUFM $ ( "RULES", ITrules_prag ), ( "RULEZ", ITrules_prag ), -- american spelling :-) ( "SCC", ITscc_prag ), + ( "CORE", ITcore_prag ), -- hdaume: core annotation ( "DEPRECATED", ITdeprecated_prag ) ] diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index be85b31..a305995 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.115 2003/02/12 15:01:37 simonpj Exp $ +$Id: Parser.y,v 1.116 2003/02/20 18:33:53 simonpj Exp $ Haskell grammar. @@ -140,6 +140,7 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002] '{-# INLINE' { ITinline_prag } '{-# NOINLINE' { ITnoinline_prag } '{-# RULES' { ITrules_prag } + '{-# CORE' { ITcore_prag } -- hdaume: annotated core '{-# SCC' { ITscc_prag } '{-# DEPRECATED' { ITdeprecated_prag } '#-}' { ITclose_prag } @@ -958,6 +959,8 @@ exp10 :: { RdrNameHsExpr } then HsSCC $1 $2 else HsPar $2 } + | '{-# CORE' STRING '#-}' exp { HsCoreAnn $2 $4 } -- hdaume: core annotation + | reifyexp { HsReify $1 } | fexp { $1 } diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index c4ddc27..9b02b79 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -265,6 +265,10 @@ rnExpr (HsCCall fun args may_gc is_casm _) cReturnableClassName, ioDataConName]) +rnExpr (HsCoreAnn ann expr) + = rnExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsCoreAnn ann expr', fvs_expr) + rnExpr (HsSCC lbl expr) = rnExpr expr `thenM` \ (expr', fvs_expr) -> returnM (HsSCC lbl expr', fvs_expr) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 674257f..945dcf5 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -869,7 +869,7 @@ rnNote (UfCoerce ty) rnNote (UfSCC cc) = returnM (UfSCC cc) rnNote UfInlineCall = returnM UfInlineCall rnNote UfInlineMe = returnM UfInlineMe - +rnNote (UfCoreNote s) = returnM (UfCoreNote s) rnUfCon UfDefault = returnM UfDefault diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 6a05a98..1967fe7 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -220,6 +220,9 @@ fiExpr to_drop (_, AnnNote InlineMe expr) fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr) = -- Just float in past coercion Note note (fiExpr to_drop expr) + +fiExpr to_drop (_, AnnNote note@(CoreNote _) expr) + = Note note (fiExpr to_drop expr) \end{code} For @Lets@, the possible ``drop points'' for the \tr{to_drop} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 5ac4877..d2b4dc9 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -842,6 +842,10 @@ simplNote env InlineMe e cont -- an interesting context of any kind to combine with -- (even a type application -- anything except Stop) = simplExprF env e cont + +simplNote env (CoreNote s) e cont + = simplExpr env e `thenSmpl` \ e' -> + rebuild env (Note (CoreNote s) e') cont \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 8174eb7..933fc51 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -536,7 +536,6 @@ mkMethId :: InstOrigin -> Class -> TcM (Maybe Inst, Id) -- mkMethId instantiates the selector Id at the specified types --- THe mkMethId origin clas sel_id inst_tys = let (tyvars,rho) = tcSplitForAllTys (idType sel_id) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 3c0376d..39e7e40 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -173,7 +173,8 @@ tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> returnM (HsSCC lbl expr') - +tcMonoExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation + returnM (HsCoreAnn lbl expr') tcMonoExpr (NegApp expr neg_name) res_ty = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty -- ToDo: use tcSyntaxName diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 79fbcd1..a09eb59 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -568,6 +568,11 @@ zonkExpr env (HsSCC lbl expr) = zonkExpr env expr `thenM` \ new_expr -> returnM (HsSCC lbl new_expr) +-- hdaume: core annotations +zonkExpr env (HsCoreAnn lbl expr) + = zonkExpr env expr `thenM` \ new_expr -> + returnM (HsCoreAnn lbl new_expr) + zonkExpr env (TyLam tyvars expr) = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> -- No need to extend tyvar env; see AbsBinds -- 1.7.10.4