packages feed

cse-ghc-plugin (empty) → 0.1.1

raw patch · 9 files changed

+503/−0 lines, 9 filesdep +basedep +ghcsetup-changed

Dependencies added: base, ghc

Files

+ AUTHORS.txt view
@@ -0,0 +1,2 @@+Original authors: many people who worked on GHC+Maintainer: Austin Seipp <mad.one@gmail.com>
+ CSE/Pass.lhs view
@@ -0,0 +1,355 @@+%+% (c) The AQUA Project, Glasgow University, 1993-1998+%+\section{Common subexpression}++\section{Notice}++This code was pilfered from GHC close to its 7.2 release, specifically, it was taken from+./compiler/simplCore/CSE.lhs, GHC version:++~ ghc --version+The Glorious Glasgow Haskell Compilation System, version 7.3.20110703+~ ++\begin{code}+{-# LANGUAGE PatternGuards #-}++module CSE.Pass ( cseProgram ) where++--import CSE.Utilities++import GhcPlugins hiding (CS)+import Data.List        ( mapAccumL )+\end{code}+++      Simple common sub-expression+      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see+  x1 = C a b+  x2 = C x1 b+we build up a reverse mapping:   C a b  -> x1+         C x1 b -> x2+and apply that to the rest of the program.++When we then see+  y1 = C a b+  y2 = C y1 b+we replace the C a b with x1.  But then we *dont* want to+add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1+so that a subsequent binding+  y2 = C y1 b+will get transformed to C x1 b, and then to x2.  ++So we carry an extra var->var substitution which we apply *before* looking up in the+reverse mapping.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+We have to be careful about shadowing.+For example, consider+  f = \x -> let y = x+x in+                h = \x -> x+x+            in ...++Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no+shadowing, but it doesn't any more (it proved too hard), so we clone as we go.+We can simply add clones to the substitution already described.++Note [Case binders 1]+~~~~~~~~~~~~~~~~~~~~~~+Consider++  f = \x -> case x of wild { +      (a:as) -> case a of wild1 {+            (p,q) -> ...(wild1:as)...++Here, (wild1:as) is morally the same as (a:as) and hence equal to wild.+But that's not quite obvious.  In general we want to keep it as (wild1:as),+but for CSE purpose that's a bad idea.++So we add the binding (wild1 -> a) to the extra var->var mapping.+Notice this is exactly backwards to what the simplifier does, which is+to try to replaces uses of 'a' with uses of 'wild1'++Note [Case binders 2]+~~~~~~~~~~~~~~~~~~~~~~+Consider+  case (h x) of y -> ...(h x)...++We'd like to replace (h x) in the alternative, by y.  But because of+the preceding [Note: case binders 1], we only want to add the mapping+  scrutinee -> case binder+to the reverse CSE mapping if the scrutinee is a non-trivial expression.+(If the scrutinee is a simple variable we want to add the mapping+  case binder -> scrutinee +to the substitution++Note [Unboxed tuple case binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  case f x of t { (# a,b #) -> +  case ... of+    True -> f x+    False -> 0 }++We must not replace (f x) by t, because t is an unboxed-tuple binder.+Instead, we shoudl replace (f x) by (# a,b #).  That is, the "reverse mapping" is+  f x --> (# a,b #)+That is why the CSEMap has pairs of expressions.++Note [CSE for INLINE and NOINLINE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are careful to do no CSE inside functions that the user has marked as+INLINE or NOINLINE.  In terms of Core, that means ++  a) we do not do CSE inside an InlineRule++  b) we do not do CSE on the RHS of a binding b=e+     unless b's InlinePragma is AlwaysActive++Here's why (examples from Roman Leshchinskiy).  Consider++  yes :: Int+  {-# NOINLINE yes #-}+  yes = undefined++  no :: Int+  {-# NOINLINE no #-}+  no = undefined++  foo :: Int -> Int -> Int+  {-# NOINLINE foo #-}+  foo m n = n++  {-# RULES "foo/no" foo no = id #-}++  bar :: Int -> Int+  bar = foo yes++We do not expect the rule to fire.  But if we do CSE, then we get+yes=no, and the rule does fire.  Worse, whether we get yes=no or+no=yes depends on the order of the definitions.++In general, CSE should probably never touch things with INLINE pragmas+as this could lead to surprising results.  Consider++  {-# INLINE foo #-}+  foo = <rhs>++  {-# NOINLINE bar #-}+  bar = <rhs> -- Same rhs as foo++If CSE produces+  foo = bar+then foo will never be inlined (when it should be); but if it produces+  bar = foo+bar will be inlined (when it should not be). Even if we remove INLINE foo,+we'd still like foo to be inlined if rhs is small. This won't happen+with foo = bar.++Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider+a worker/wrapper, in which the worker has turned into a single variable:+  $wf = h+  f = \x -> ...$wf...+Now CSE may transform to+  f = \x -> ...h...+But the WorkerInfo for f still says $wf, which is now dead!  This won't+happen now that we don't look inside INLINEs (which wrappers are).+++%************************************************************************+%*                  *+\section{Common subexpression}+%*                  *+%************************************************************************++\begin{code}+cseProgram :: [CoreBind] -> CoreM [CoreBind]+cseProgram binds = return $ cseBinds emptyCSEnv binds++cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]+cseBinds _   []     = []+cseBinds env (b:bs) = (b':bs')+        where+          (env1, b') = cseBind  env  b+          bs'        = cseBinds env1 bs++cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)+cseBind env (NonRec b e) +  = (env2, NonRec b' e')+  where+    (env1, b') = addBinder env b+    (env2, e') = cseRhs env1 (b',e)++cseBind env (Rec pairs)+  = (env2, Rec (bs' `zip` es'))+  where+    (bs,es) = unzip pairs+    (env1, bs') = addRecBinders env bs+    (env2, es') = mapAccumL cseRhs env1 (bs' `zip` es)++cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr)+cseRhs env (id',rhs)+  = case lookupCSEnv env rhs' of+  Just other_expr     -> (env,               other_expr)+  Nothing             -> (addCSEnvItem env rhs' (Var id'), rhs')+  where+    rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs+         | otherwise                 = rhs+    -- See Note [CSE for INLINE and NOINLINE]++tryForCSE :: CSEnv -> InExpr -> OutExpr+tryForCSE _   (Type t) = Type t+tryForCSE _   (Coercion c) = Coercion c+tryForCSE env expr     = case lookupCSEnv env expr' of+          Just smaller_expr -> smaller_expr+          Nothing         -> expr'+  where+    expr' = cseExpr env expr++cseExpr :: CSEnv -> InExpr -> OutExpr+cseExpr _   (Type t)               = Type t+cseExpr _   (Coercion co)          = Coercion co+cseExpr _   (Lit lit)              = Lit lit+cseExpr env (Var v)      = lookupSubst env v+cseExpr env (App f a)            = App (cseExpr env f) (tryForCSE env a)+cseExpr env (Tick t e)           = Tick t (cseExpr env e)+cseExpr env (Cast e co)            = Cast (cseExpr env e) co+cseExpr env (Lam b e)          = let (env', b') = addBinder env b+             in Lam b' (cseExpr env' e)+cseExpr env (Let bind e)         = let (env', bind') = cseBind env bind+             in Let bind' (cseExpr env' e)+cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts'+           where+             alts' = cseAlts env' scrut' bndr bndr'' alts+             scrut' = tryForCSE env scrut+             (env', bndr') = addBinder env bndr+             bndr'' = zapIdOccInfo bndr'+          -- The swizzling from Note [Case binders 2] may+          -- cause a dead case binder to be alive, so we+          -- play safe here and bring them all to life++cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt]++cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)]+  | isUnboxedTupleCon con+  -- Unboxed tuples are special because the case binder isn't+  -- a real value.  See Note [Unboxed tuple case binders]+  = [(DataAlt con, args'', tryForCSE new_env rhs)]+  where+    (env', args') = addBinders env args+    args'' = map zapIdOccInfo args' -- They should all be ids+  -- Same motivation for zapping as [Case binders 2] only this time+  -- it's Note [Unboxed tuple case binders]+    new_env | exprIsCheap scrut' = env'+      | otherwise    = extendCSEnv env' scrut' tup_value+    tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr))++cseAlts env scrut' bndr bndr' alts+  = map cse_alt alts+  where+    (con_target, alt_env) = case scrut' of+      Var v' -> (v',     extendCSSubst env bndr v') -- See Note [Case binders 1]+                -- map: bndr -> v'++      _      ->  (bndr', extendCSEnv env scrut' (Var  bndr')) -- See Note [Case binders 2]+                    -- map: scrut' -> bndr'++    arg_tys = tyConAppArgs (idType bndr)++    cse_alt (DataAlt con, args, rhs)+      | not (null args)+        -- Don't try CSE if there are no args; it just increases the number+        -- of live vars.  E.g.+        --  case x of { True -> ....True.... }+        -- Don't replace True by x!  +        -- Hence the 'null args', which also deal with literals and DEFAULT+      = (DataAlt con, args', tryForCSE new_env rhs)+      where+        (env', args') = addBinders alt_env args+        new_env       = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) (Var con_target)++    cse_alt (con, args, rhs) = (con, args', tryForCSE env' rhs)+      where (env', args') = addBinders alt_env args+\end{code}+++%************************************************************************+%*                  *+\section{The CSE envt}+%*                  *+%************************************************************************++\begin{code}+type InExpr  = CoreExpr   -- Pre-cloning+type InBndr  = CoreBndr+type InAlt   = CoreAlt++type OutExpr  = CoreExpr  -- Post-cloning+type OutBndr  = CoreBndr+type OutAlt   = CoreAlt++data CSEnv  = CS CSEMap Subst+type CSEMap = UniqFM [(OutExpr, OutExpr)] -- This is the reverse mapping+  -- It maps the hash-code of an expression e to list of (e,e') pairs+  -- This means that it's good to replace e by e'+  -- INVARIANT: The expr in the range has already been CSE'd++emptyCSEnv :: CSEnv+emptyCSEnv = CS emptyUFM emptySubst++lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr+lookupCSEnv (CS cs sub) expr+  = case lookupUFM cs (hashExpr expr) of+  Nothing -> Nothing+  Just pairs -> lookup_list pairs+  where+  -- In this lookup we use full expression equality+  -- Reason: when expressions differ we generally find out quickly+  --         but I found that cheapEqExpr was saying (\x.x) /= (\y.y),+  --       and this kind of thing happened in real programs+    lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr+    lookup_list ((e,e'):es) +      | eqExpr (substInScope sub) e expr = Just e'+      | otherwise                  = lookup_list es+    lookup_list []                       = Nothing++addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv+addCSEnvItem env expr expr' | exprIsBig expr = env+          | otherwise      = extendCSEnv env expr expr'+   -- We don't try to CSE big expressions, because they are expensive to compare+   -- (and are unlikely to be the same anyway)++extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv+extendCSEnv (CS cs sub) expr expr'+  = CS (addToUFM_C combine cs hash [(expr, expr')]) sub+  where+    hash = hashExpr expr+    combine old new = result+     where+        result = new ++ old++lookupSubst :: CSEnv -> Id -> OutExpr+lookupSubst (CS _ sub) x = lookupIdSubst (text "CSE.lookupSubst") sub x++extendCSSubst :: CSEnv -> Id  -> Id -> CSEnv+extendCSSubst (CS cs sub) x y = CS cs (extendIdSubst sub x (Var y))++addBinder :: CSEnv -> Var -> (CSEnv, Var)+addBinder (CS cs sub) v = (CS cs sub', v') +                        where+                          (sub', v') = substBndr sub v++addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])+addBinders (CS cs sub) vs = (CS cs sub', vs') +                          where+                            (sub', vs') = substBndrs sub vs++addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])+addRecBinders (CS cs sub) vs = (CS cs sub', vs') +                          where+                            (sub', vs') = substRecBndrs sub vs+\end{code}
+ CSE/Plugin.hs view
@@ -0,0 +1,18 @@+module CSE.Plugin+       ( plugin -- :: Plugin+       ) where++import CSE.Pass (cseProgram)+import GhcPlugins++plugin :: Plugin+plugin = defaultPlugin {+    installCoreToDos = install+  }++-- You should probably run this with -fno-cse !+install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+install _ todos = do+    reinitializeGlobals+    return $ CoreDoPasses [cse] : todos+  where cse = CoreDoPluginPass "Common Subexpression Elimination" (bindsOnlyPass cseProgram)
+ LICENSE.txt view
@@ -0,0 +1,31 @@+The Glasgow Haskell Compiler License++Copyright 2002, The University Court of the University of Glasgow.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ README.md view
@@ -0,0 +1,40 @@+# GHC plugin for Common Subexpression Elimination (CSE)++This plugin gives an example of defining a compiler plugin for+GHC. The implementation of this optimization is ripped directly from+GHC itself.++[travis-ci.org](http://travis-ci.org) results: [![Build Status](https://secure.travis-ci.org/thoughtpolice/cse-ghc-plugin.png?branch=master)](http://travis-ci.org/thoughtpolice/cse-ghc-plugin)++[Homepage][main page].++# Installation++Install the latest version of the plugin from Hackage (requires GHC 7.4.1):++    $ cabal install cse-ghc-plugin++# Join in++File bugs in the GitHub [issue tracker][].++Master [git repository][gh]:++* `git clone https://github.com/thoughtpolice/cse-ghc-plugin.git`++There's also a [BitBucket mirror][bb]:++* `git clone https://bitbucket.org/thoughtpolice/cse-ghc-plugin.git`++# Authors++See [AUTHORS.txt](https://raw.github.com/thoughtpolice/cse-ghc-plugin/master/AUTHORS.txt).++# License++BSD3. See `LICENSE.txt` for terms of copyright and redistribution.++[main page]: http://thoughtpolice.github.com/cse-ghc-plugin+[issue tracker]: http://github.com/thoughtpolice/cse-ghc-plugin/issues+[gh]: http://github.com/thoughtpolice/cse-ghc-plugin+[bb]: http://bitbucket.org/thoughtpolice/cse-ghc-plugin
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ cse-ghc-plugin.cabal view
@@ -0,0 +1,40 @@+name:                cse-ghc-plugin+version:             0.1.1+synopsis:            Compiler plugin for common subexpression elimination+description:+  This library is a conversion of GHC's internal Common Subexpression+  Elimination pass for Core to a compiler plugin. See the included test+  for an example of how to enable it.+homepage:            http://thoughtpolice.github.com/cse-ghc-plugin+bug-reports:         http://github.com/thoughtpolice/cse-ghc-plugin/issues+license:             BSD3+license-file:        LICENSE.txt+copyright:           Copyright (c) the GHC authors+author:              The GHC authors+maintainer:          Austin Seipp <mad.one@gmail.com>+category:            Compiler Plugin+build-type:          Simple+cabal-version:       >=1.10+tested-with:         GHC == 7.4.1++extra-source-files:+  AUTHORS.txt README.md+  tests/*.hs tests/Makefile++source-repository head+  type: git+  location: https://github.com/thoughtpolice/cse-ghc-plugin.git++library+  exposed-modules:+    CSE.Plugin+  other-modules:+    CSE.Pass+  build-depends:+    base < 5,+    ghc >= 7.4++  ghc-options:        -Wall -O2 -funbox-strict-fields+                      -fwarn-tabs+  default-extensions: CPP+  default-language:   Haskell2010
+ tests/Makefile view
@@ -0,0 +1,4 @@+all:+	ghc -fno-cse -O2 -fforce-recomp -fplugin CSE.Plugin Traced.hs+clean:+	rm -f *.o *.hi Traced
+ tests/Traced.hs view
@@ -0,0 +1,10 @@+module Main ( main ) where++import Debug.Trace+import Control.Exception ( evaluate )++main :: IO ()+main = do+    putStrLn "The test is successful if the word 'Evaluated' appears only once below:"+    evaluate $ let x = trace "Evaluated" (1 + 1) in x + (trace "Evaluated" (1 + 1)) + x+    return ()