Permalink
Browse files

Sample GHC plugins project.

Signed-off-by: Edward Z. Yang <ezyang@mit.edu>
  • Loading branch information...
0 parents commit 088f276bc573ba6d785668b9304d67d2afad7827 @ezyang committed Sep 28, 2012
@@ -0,0 +1,8 @@
+_darcs
+*.o
+*.hi
+*~
+dist*
+tests/*.o
+tests/*.hi
+tests/Traced
@@ -0,0 +1,14 @@
+module GhcPlugins.Template ( plugin ) where
+
+import GhcPlugins.Template.Pass
+import GhcPlugins
+
+plugin :: Plugin
+plugin = defaultPlugin {
+ installCoreToDos = install
+ }
+
+install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+install _ todos = do
+ reinitializeGlobals
+ return $ CoreDoPluginPass "Template" transformProgram : todos
@@ -0,0 +1,16 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module GhcPlugins.Template.Annotation where
+
+import Data.Data
+
+-- | Annotations are a convenient way of marking bindings and
+-- expressions in a way that can be found by the core pass;
+-- for example, if you only want to apply your transformation
+-- when the user explicitly requests it for some code. See
+-- http://www.haskell.org/ghc/docs/latest/html/users_guide/compiler-plugins.html#getting-annotations
+-- for more details. This particular annotation can be used as
+-- {-# ANN identifierName Template #-} after importing this module; see
+-- http://www.haskell.org/ghc/docs/latest/html/users_guide/extending-ghc.html#annotation-pragmas
+-- for more details, including what extra data annotations support.
+
+data Template = Template deriving (Typeable, Data)
@@ -0,0 +1,73 @@
+{-# LANGUAGE PatternGuards #-}
+
+module GhcPlugins.Template.Pass (transformProgram) where
+
+import GhcPlugins
+
+import Control.Monad
+import Data.Generics
+
+import GhcPlugins.Template.Annotation
+
+-- ModGuts has a lot of fields, but mg_binds contains the top-level
+-- bindings. Defined in 'compiler/main/HscTypes.lhs'
+transformProgram :: ModGuts -> CoreM ModGuts
+transformProgram guts = do
+ newBinds <- mapM (transformFunc guts) (mg_binds guts)
+ return $ guts { mg_binds = newBinds }
+
+-- CoreBind = Bind CoreBndr, which are either recursive or non-recursive.
+-- Defined in 'compiler/coreSyn/CoreSyn.lhs', CoreBndr is a Var which
+-- is defined in 'compiler/basicTypes/Var.lhs'
+transformFunc :: ModGuts -> CoreBind -> CoreM CoreBind
+transformFunc guts x = do
+ b <- shouldTransformBind guts x
+ if b
+ then everywhereM (mkM transformExpr) x -- mkM/everywhereM are from 'syb'
+ else return x
+
+shouldTransformBind guts (NonRec b _) = shouldTransform guts b
+shouldTransformBind guts (Rec bs) = and `liftM` mapM (shouldTransform guts . fst) bs
+
+-- CoreExpr = Expr CoreBndr, which is the meat of Core. Defined in
+-- 'compiler/coreSyn/CoreSyn.lhs'. The sample code here is just a
+-- very verbose identity transformation. Recall CoreBndr is a Var.
+--
+-- Note: we're using everywhereM to invoke this function, so you do
+-- *not* need to make recursive subcalls, they will automatically be
+-- made for you. If you need a traversal that terminates early,
+-- try some of the other functions in Data.Generics.Schemes
+--
+-- Things which you might need to do:
+-- * Allocate a fresh name: use mkSysLocalM, e.g.
+-- mkSysLocalM (fsLit "somePrefix") typeOfExpr
+-- * Determine the type of an expression: exprType
+transformExpr :: CoreExpr -> CoreM CoreExpr
+-- See 'Id'/'Var' in 'compiler/basicTypes/Var.lhs' (note: it's opaque)
+transformExpr e@(Var x) | isTyVar x = return e
+ | isTcTyVar x = return e
+ | isLocalId x = return e
+ | isGlobalId x = return e
+-- See 'Literal' in 'compiler/basicTypes/Literal.lhs'
+transformExpr e@(Lit l) = return e
+transformExpr e@(App e1 e2) = return e
+transformExpr e@(Lam x e1) = return e
+-- b is a Bind CoreBndr, which is the same as CoreBind
+transformExpr e@(Let b e1) = return e
+-- Remember case in core is strict!
+transformExpr e@(Case e1 b t as) = return e
+-- XXX These are pretty esoteric...
+transformExpr e@(Cast e1 c) = return e
+transformExpr e@(Tick t e1) = return e
+transformExpr e@(Type t) = return e
+transformExpr e@(Coercion c) = return e
+
+shouldTransform :: ModGuts -> CoreBndr -> CoreM Bool
+shouldTransform guts bndr = do
+ l <- annotationsOn guts bndr :: CoreM [Template]
+ return $ not (null l)
+
+annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a]
+annotationsOn guts bndr = do
+ anns <- getAnnotations deserializeWithData guts
+ return $ lookupWithDefaultUFM anns [] (varUnique bndr)
@@ -0,0 +1,29 @@
+name: ghc-plugin-template
+version: 0.0.1
+synopsis: Template for writing GHC plugins
+description:
+ This plugin gives an example of defining a compiler plugin for
+ GHC. You mark functions with the `Strictify` annotation and GHC
+ makes the function strict (by recursively expanding non-recursive
+ let bindings into case bindings.)
+license: PublicDomain
+author: Edward Z. Yang <ezyang@mit.edu>
+maintainer: Edward Z. Yang <ezyang@mit.edu>
+category: Compiler Plugin
+build-type: Simple
+cabal-version: >=1.10
+tested-with: GHC == 7.4.3
+
+library
+ exposed-modules:
+ GhcPlugins.Template
+ GhcPlugins.Template.Annotation
+ other-modules:
+ GhcPlugins.Template.Pass
+ build-depends:
+ base < 5,
+ ghc >= 7.4,
+ syb
+
+ default-extensions: CPP
+ default-language: Haskell2010
@@ -0,0 +1,4 @@
+all:
+ ghc -O2 -fforce-recomp -fplugin GhcPlugins.Template SampleTest
+clean:
+ rm -f *.o *.hi SampleTest
Binary file not shown.
@@ -0,0 +1 @@
+main = print "Test"

0 comments on commit 088f276

Please sign in to comment.