[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.

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 7ab6894..8f4a89d 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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