Commit 56b5a8b8 authored by simonpj's avatar simonpj
Browse files

[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 _ _) ...@@ -454,10 +454,11 @@ corePrepExprFloat env expr@(App _ _)
where where
ty = exprType fun ty = exprType fun
ignore_note InlineCall = True ignore_note (CoreNote _) = True
ignore_note InlineMe = True ignore_note InlineCall = True
ignore_note _other = False ignore_note InlineMe = True
-- we don't ignore SCCs, since they require some code generation ignore_note _other = False
-- We don't ignore SCCs, since they require some code generation
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Building the saturated syntax -- Building the saturated syntax
......
...@@ -109,6 +109,8 @@ data Note ...@@ -109,6 +109,8 @@ data Note
| InlineMe -- Instructs simplifer to treat the enclosed expression | InlineMe -- Instructs simplifer to treat the enclosed expression
-- as very small, and inline it at its call sites -- 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 -- NOTE: we also treat expressions wrapped in InlineMe as
-- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable) -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
-- What this means is that we obediently inline even things that don't -- What this means is that we obediently inline even things that don't
...@@ -549,6 +551,7 @@ seqExprs [] = () ...@@ -549,6 +551,7 @@ seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es seqExprs (e:es) = seqExpr e `seq` seqExprs es
seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2 seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
seqNote (CoreNote s) = s `seq` ()
seqNote other = () seqNote other = ()
seqBndr b = b `seq` () seqBndr b = b `seq` ()
......
...@@ -1045,6 +1045,7 @@ eqExpr e1 e2 ...@@ -1045,6 +1045,7 @@ eqExpr e1 e2
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2 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 (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
eq_note env InlineCall InlineCall = True eq_note env InlineCall InlineCall = True
eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
eq_note env other1 other2 = False eq_note env other1 other2 = False
\end{code} \end{code}
...@@ -1075,6 +1076,7 @@ noteSize (SCC cc) = cc `seq` 1 ...@@ -1075,6 +1076,7 @@ noteSize (SCC cc) = cc `seq` 1
noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
noteSize InlineCall = 1 noteSize InlineCall = 1
noteSize InlineMe = 1 noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
varSize :: Var -> Int varSize :: Var -> Int
varSize b | isTyVar b = 1 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 ...@@ -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 (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 (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 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 (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
make_exp _ = error "MkExternalCore died: make_exp" make_exp _ = error "MkExternalCore died: make_exp"
......
...@@ -44,6 +44,7 @@ import PprType ( pprParendType, pprType, pprTyVarBndr ) ...@@ -44,6 +44,7 @@ import PprType ( pprParendType, pprType, pprTyVarBndr )
import BasicTypes ( tupleParens ) import BasicTypes ( tupleParens )
import Util ( lengthIs ) import Util ( lengthIs )
import Outputable import Outputable
import FastString ( mkFastString )
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -235,6 +236,11 @@ ppr_expr add_par (Note InlineCall expr) ...@@ -235,6 +236,11 @@ ppr_expr add_par (Note InlineCall expr)
ppr_expr add_par (Note InlineMe expr) ppr_expr add_par (Note InlineMe expr)
= add_par $ ptext SLIT("__inline_me") <+> pprParendExpr 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) pprCoreAlt (con, args, rhs)
= hang (ppr_case_pat con args) 2 (pprCoreExpr rhs) = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
......
...@@ -241,6 +241,13 @@ dsExpr (HsSCC cc expr) ...@@ -241,6 +241,13 @@ dsExpr (HsSCC cc expr)
getModuleDs `thenDs` \ mod_name -> getModuleDs `thenDs` \ mod_name ->
returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr) 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. -- special case to handle unboxed tuple patterns.
dsExpr (HsCase discrim matches src_loc) dsExpr (HsCase discrim matches src_loc)
......
...@@ -488,6 +488,7 @@ repE (ArithSeqIn aseq) = ...@@ -488,6 +488,7 @@ repE (ArithSeqIn aseq) =
ds3 <- repE e3 ds3 <- repE e3
repFromThenTo ds1 ds2 ds3 repFromThenTo ds1 ds2 ds3
repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" 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 (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
repE (HsBracketOut _ _) = repE (HsBracketOut _ _) =
......
...@@ -76,6 +76,7 @@ data UfNote name = UfSCC CostCentre ...@@ -76,6 +76,7 @@ data UfNote name = UfSCC CostCentre
| UfCoerce (HsType name) | UfCoerce (HsType name)
| UfInlineCall | UfInlineCall
| UfInlineMe | UfInlineMe
| UfCoreNote String
type UfAlt name = (UfConAlt name, [name], UfExpr name) type UfAlt name = (UfConAlt name, [name], UfExpr name)
...@@ -124,6 +125,7 @@ toUfNote (SCC cc) = UfSCC cc ...@@ -124,6 +125,7 @@ toUfNote (SCC cc) = UfSCC cc
toUfNote (Coerce t1 _) = UfCoerce (toHsType t1) toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
toUfNote InlineCall = UfInlineCall toUfNote InlineCall = UfInlineCall
toUfNote InlineMe = UfInlineMe toUfNote InlineMe = UfInlineMe
toUfNote (CoreNote s) = UfCoreNote s
--------------------- ---------------------
toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r) toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
...@@ -252,6 +254,7 @@ instance Outputable name => Outputable (UfNote name) where ...@@ -252,6 +254,7 @@ instance Outputable name => Outputable (UfNote name) where
ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
ppr UfInlineCall = ptext SLIT("__inline_call") ppr UfInlineCall = ptext SLIT("__inline_call")
ppr UfInlineMe = ptext SLIT("__inline_me") ppr UfInlineMe = ptext SLIT("__inline_me")
ppr (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
instance Outputable name => Outputable (UfConAlt name) where instance Outputable name => Outputable (UfConAlt name) where
ppr UfDefault = text "__DEFAULT" ppr UfDefault = text "__DEFAULT"
...@@ -353,6 +356,7 @@ eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2) ...@@ -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 (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
eq_ufNote UfInlineCall UfInlineCall = True eq_ufNote UfInlineCall UfInlineCall = True
eq_ufNote UfInlineMe UfInlineMe = True eq_ufNote UfInlineMe UfInlineMe = True
eq_ufNote (UfCoreNote s1) (UfCoreNote s2) = s1==s2
eq_ufNote _ _ = False eq_ufNote _ _ = False
eq_ufExpr env _ _ = False eq_ufExpr env _ _ = False
......
...@@ -157,6 +157,9 @@ data HsExpr id ...@@ -157,6 +157,9 @@ data HsExpr id
| HsSCC FastString -- "set cost centre" (_scc_) annotation | HsSCC FastString -- "set cost centre" (_scc_) annotation
(HsExpr id) -- expr whose cost is to be measured (HsExpr id) -- expr whose cost is to be measured
| HsCoreAnn FastString -- hdaume: core annotation
(HsExpr id)
-- MetaHaskell Extensions -- MetaHaskell Extensions
| HsBracket (HsBracket id) SrcLoc | HsBracket (HsBracket id) SrcLoc
......
...@@ -940,6 +940,9 @@ instance (Binary name) => Binary (UfNote name) where ...@@ -940,6 +940,9 @@ instance (Binary name) => Binary (UfNote name) where
putByte bh 2 putByte bh 2
put_ bh UfInlineMe = do put_ bh UfInlineMe = do
putByte bh 3 putByte bh 3
put_ bh (UfCoreNote s) = do
putByte bh 4
put_ bh s
get bh = do get bh = do
h <- getByte bh h <- getByte bh
case h of case h of
...@@ -948,7 +951,9 @@ instance (Binary name) => Binary (UfNote name) where ...@@ -948,7 +951,9 @@ instance (Binary name) => Binary (UfNote name) where
1 -> do ab <- get bh 1 -> do ab <- get bh
return (UfCoerce ab) return (UfCoerce ab)
2 -> do return UfInlineCall 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 instance (Binary name) => Binary (BangType name) where
put_ bh (BangType aa ab) = do put_ bh (BangType aa ab) = do
......
...@@ -133,6 +133,7 @@ data Token ...@@ -133,6 +133,7 @@ data Token
| ITdeprecated_prag | ITdeprecated_prag
| ITline_prag | ITline_prag
| ITscc_prag | ITscc_prag
| ITcore_prag -- hdaume: core annotations
| ITclose_prag | ITclose_prag
| ITdotdot -- reserved symbols | ITdotdot -- reserved symbols
...@@ -230,6 +231,7 @@ pragmaKeywordsFM = listToUFM $ ...@@ -230,6 +231,7 @@ pragmaKeywordsFM = listToUFM $
( "RULES", ITrules_prag ), ( "RULES", ITrules_prag ),
( "RULEZ", ITrules_prag ), -- american spelling :-) ( "RULEZ", ITrules_prag ), -- american spelling :-)
( "SCC", ITscc_prag ), ( "SCC", ITscc_prag ),
( "CORE", ITcore_prag ), -- hdaume: core annotation
( "DEPRECATED", ITdeprecated_prag ) ( "DEPRECATED", ITdeprecated_prag )
] ]
......
{- -*-haskell-*- {- -*-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. Haskell grammar.
...@@ -140,6 +140,7 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002] ...@@ -140,6 +140,7 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
'{-# INLINE' { ITinline_prag } '{-# INLINE' { ITinline_prag }
'{-# NOINLINE' { ITnoinline_prag } '{-# NOINLINE' { ITnoinline_prag }
'{-# RULES' { ITrules_prag } '{-# RULES' { ITrules_prag }
'{-# CORE' { ITcore_prag } -- hdaume: annotated core
'{-# SCC' { ITscc_prag } '{-# SCC' { ITscc_prag }
'{-# DEPRECATED' { ITdeprecated_prag } '{-# DEPRECATED' { ITdeprecated_prag }
'#-}' { ITclose_prag } '#-}' { ITclose_prag }
...@@ -958,6 +959,8 @@ exp10 :: { RdrNameHsExpr } ...@@ -958,6 +959,8 @@ exp10 :: { RdrNameHsExpr }
then HsSCC $1 $2 then HsSCC $1 $2
else HsPar $2 } else HsPar $2 }
| '{-# CORE' STRING '#-}' exp { HsCoreAnn $2 $4 } -- hdaume: core annotation
| reifyexp { HsReify $1 } | reifyexp { HsReify $1 }
| fexp { $1 } | fexp { $1 }
......
...@@ -265,6 +265,10 @@ rnExpr (HsCCall fun args may_gc is_casm _) ...@@ -265,6 +265,10 @@ rnExpr (HsCCall fun args may_gc is_casm _)
cReturnableClassName, cReturnableClassName,
ioDataConName]) ioDataConName])
rnExpr (HsCoreAnn ann expr)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsCoreAnn ann expr', fvs_expr)
rnExpr (HsSCC lbl expr) rnExpr (HsSCC lbl expr)
= rnExpr expr `thenM` \ (expr', fvs_expr) -> = rnExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsSCC lbl expr', fvs_expr) returnM (HsSCC lbl expr', fvs_expr)
......
...@@ -869,7 +869,7 @@ rnNote (UfCoerce ty) ...@@ -869,7 +869,7 @@ rnNote (UfCoerce ty)
rnNote (UfSCC cc) = returnM (UfSCC cc) rnNote (UfSCC cc) = returnM (UfSCC cc)
rnNote UfInlineCall = returnM UfInlineCall rnNote UfInlineCall = returnM UfInlineCall
rnNote UfInlineMe = returnM UfInlineMe rnNote UfInlineMe = returnM UfInlineMe
rnNote (UfCoreNote s) = returnM (UfCoreNote s)
rnUfCon UfDefault rnUfCon UfDefault
= returnM UfDefault = returnM UfDefault
......
...@@ -220,6 +220,9 @@ fiExpr to_drop (_, AnnNote InlineMe expr) ...@@ -220,6 +220,9 @@ fiExpr to_drop (_, AnnNote InlineMe expr)
fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr) fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
= -- Just float in past coercion = -- Just float in past coercion
Note note (fiExpr to_drop expr) Note note (fiExpr to_drop expr)
fiExpr to_drop (_, AnnNote note@(CoreNote _) expr)
= Note note (fiExpr to_drop expr)
\end{code} \end{code}
For @Lets@, the possible ``drop points'' for the \tr{to_drop} For @Lets@, the possible ``drop points'' for the \tr{to_drop}
......
...@@ -842,6 +842,10 @@ simplNote env InlineMe e cont ...@@ -842,6 +842,10 @@ simplNote env InlineMe e cont
-- an interesting context of any kind to combine with -- an interesting context of any kind to combine with
-- (even a type application -- anything except Stop) -- (even a type application -- anything except Stop)
= simplExprF env e cont = simplExprF env e cont
simplNote env (CoreNote s) e cont
= simplExpr env e `thenSmpl` \ e' ->
rebuild env (Note (CoreNote s) e') cont
\end{code} \end{code}
......
...@@ -536,7 +536,6 @@ mkMethId :: InstOrigin -> Class ...@@ -536,7 +536,6 @@ mkMethId :: InstOrigin -> Class
-> TcM (Maybe Inst, Id) -> TcM (Maybe Inst, Id)
-- mkMethId instantiates the selector Id at the specified types -- mkMethId instantiates the selector Id at the specified types
-- THe
mkMethId origin clas sel_id inst_tys mkMethId origin clas sel_id inst_tys
= let = let
(tyvars,rho) = tcSplitForAllTys (idType sel_id) (tyvars,rho) = tcSplitForAllTys (idType sel_id)
......
...@@ -173,7 +173,8 @@ tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> ...@@ -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' -> tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
returnM (HsSCC lbl 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 (NegApp expr neg_name) res_ty
= tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty
-- ToDo: use tcSyntaxName -- ToDo: use tcSyntaxName
......
...@@ -568,6 +568,11 @@ zonkExpr env (HsSCC lbl expr) ...@@ -568,6 +568,11 @@ zonkExpr env (HsSCC lbl expr)
= zonkExpr env expr `thenM` \ new_expr -> = zonkExpr env expr `thenM` \ new_expr ->
returnM (HsSCC lbl 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) zonkExpr env (TyLam tyvars expr)
= mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
-- No need to extend tyvar env; see AbsBinds -- 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