Commit 56b5a8b8 authored by simonpj's avatar simonpj

[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.
parent 8589a690
......@@ -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
......
......@@ -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` ()
......
......@@ -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
......
......@@ -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"
......
......@@ -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)
......
......@@ -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)
......
......@@ -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 _ _) =
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 )
]
......
{- -*-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 }
......
......@@ -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)
......
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
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