\section{Common subexpression}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module CSE (
cseProgram
) where
#include "HsVersions.h"
import DynFlags ( DynFlag(..), DynFlags )
-import Id ( Id, idType, idWorkerInfo )
-import IdInfo ( workerExists )
+import Id ( Id, idType, idInlinePragma )
import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
import VarEnv
import CoreLint ( showPass, endPass )
import Outputable
-import Util ( mapAccumL, lengthExceeds )
+import StaticFlags ( opt_PprStyle_Debug )
+import BasicTypes ( isAlwaysActive )
+import Util ( lengthExceeds )
import UniqFM
+
+import Data.List
\end{code}
f x --> (# a,b #)
That is why the CSEMap has pairs of expressions.
+Note [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 (Note InlineMe e)
+
+ 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 transoform 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).
+
%************************************************************************
%* *
Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs'))
where
(env', id') = addBinder env id
- rhs' | not (workerExists (idWorkerInfo id)) = cseExpr env' rhs
-
- -- Hack alert: don't do CSE on wrapper RHSs.
- -- Otherwise we find:
- -- $wf = h
- -- f = \x -> ...$wf...
- -- ===>
- -- f = \x -> ...h...
- -- But the WorkerInfo for f still says $wf, which is now dead!
- | otherwise = rhs
-
+ rhs' | isAlwaysActive (idInlinePragma id) = cseExpr env' rhs
+ | otherwise = rhs
+ -- See Note [INLINE and NOINLINE]
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
tryForCSE env (Type t) = Type t
cseExpr env (Lit lit) = Lit lit
cseExpr env (Var v) = Var (lookupSubst env v)
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
+cseExpr evn (Note InlineMe e) = Note InlineMe e -- See Note [INLINE and NOINLINE]
cseExpr env (Note n e) = Note n (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
extendCSEnv (CS cs in_scope sub) expr expr'
= CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub
where
- hash = hashExpr expr
- combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
- result
- where
- result = new ++ old
+ hash = hashExpr expr
+ combine old new
+ = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
+ where
+ result = new ++ old
+ short_msg = ptext SLIT("extendCSEnv: long list, length") <+> int (length result)
+ long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result
+ | otherwise = empty
lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of
Just y -> y
addBinder env@(CS cs in_scope sub) v
| not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
| isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
- | not (isId v) = WARN( True, ppr v )
+ | otherwise = WARN( True, ppr v )
(CS emptyUFM in_scope sub, v)
-- This last case is the unusual situation where we have shadowing of
-- a type variable; we have to discard the CSE mapping
projects / ghc-hetmet.git / blobdiff