X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=d48d69eb81886ab969774f8d05e25fac69059eb8;hb=e04195659aa59e83af80790c0179dd87e956a8b6;hp=0708d7aa7582add1bfbb205f4854d8d306da8ab6;hpb=9414bda057e8ac8422ca5590c8500c7cdee323bb;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 0708d7a..d48d69e 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -51,6 +51,7 @@ import PprCore
 import Var
 import SrcLoc
 import VarEnv
+import VarSet
 import Name
 import Module
 #if mingw32_TARGET_OS
@@ -74,8 +75,6 @@ import Maybes
 import Util
 import Data.Word
 import Data.Bits
-
-import GHC.Exts		-- For `xori` 
 \end{code}
 
 
@@ -105,7 +104,13 @@ exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 
 coreAltType :: CoreAlt -> Type
 -- ^ Returns the type of the alternatives right hand side
-coreAltType (_,_,rhs) = exprType rhs
+coreAltType (_,bs,rhs) 
+  | any bad_binder bs = expandTypeSynonyms ty
+  | otherwise         = ty    -- Note [Existential variables and silly type synonyms]
+  where
+    ty           = exprType rhs
+    free_tvs     = tyVarsOfType ty
+    bad_binder b = isTyVar b && b `elemVarSet` free_tvs
 
 coreAltsType :: [CoreAlt] -> Type
 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
@@ -113,6 +118,30 @@ coreAltsType (alt:_) = coreAltType alt
 coreAltsType []	     = panic "corAltsType"
 \end{code}
 
+Note [Existential variables and silly type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+	data T = forall a. T (Funny a)
+	type Funny a = Bool
+	f :: T -> Bool
+	f (T x) = x
+
+Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.
+That means that 'exprType' and 'coreAltsType' may give a result that *appears*
+to mention an out-of-scope type variable.  See Trac #3409 for a more real-world
+example.
+
+Various possibilities suggest themselves:
+
+ - Ignore the problem, and make Lint not complain about such variables
+
+ - Expand all type synonyms (or at least all those that discard arguments)
+      This is tricky, because at least for top-level things we want to
+      retain the type the user originally specified.
+
+ - Expand synonyms on the fly, when the problem arises. That is what
+   we are doing here.  It's not too expensive, I think.
+
 \begin{code}
 mkPiType  :: Var   -> Type -> Type
 -- ^ Makes a @(->)@ type or a forall type, depending
@@ -200,8 +229,9 @@ But it hardly seems worth it, so I don't bother.
 -- | Wraps the given expression in an inlining hint unless the expression
 -- is trivial in some sense, so that doing so would usually hurt us
 mkInlineMe :: CoreExpr -> CoreExpr
-mkInlineMe (Var v) = Var v
-mkInlineMe e	   = Note InlineMe e
+mkInlineMe e@(Var _)           = e
+mkInlineMe e@(Note InlineMe _) = e
+mkInlineMe e	               = Note InlineMe e
 \end{code}
 
 \begin{code}
@@ -400,6 +430,8 @@ filters down the matching alternatives in Simplify.rebuildCase.
 		applications.  Note that primop Ids aren't considered
 		trivial unless 
 
+Note [Variable are trivial]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
 There used to be a gruesome test for (hasNoBinding v) in the
 Var case:
 	exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
@@ -411,19 +443,22 @@ completely un-applied primops and foreign-call Ids are sufficiently
 rare that I plan to allow them to be duplicated and put up with
 saturating them.
 
-SCC notes.  We do not treat (_scc_ "foo" x) as trivial, because 
-  a) it really generates code, (and a heap object when it's 
-     a function arg) to capture the cost centre
-  b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
+Note [SCCs are trivial]
+~~~~~~~~~~~~~~~~~~~~~~~
+We used not to treat (_scc_ "foo" x) as trivial, because it really
+generates code, (and a heap object when it's a function arg) to
+capture the cost centre.  However, the profiling system discounts the
+allocation costs for such "boxing thunks" whereas the extra costs of
+*not* inlining otherwise-trivial bindings can be high, and are hard to
+discount.
 
 \begin{code}
 exprIsTrivial :: CoreExpr -> Bool
-exprIsTrivial (Var _)          = True        -- See notes above
+exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
 exprIsTrivial (Type _)         = True
 exprIsTrivial (Lit lit)        = litIsTrivial lit
 exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
-exprIsTrivial (Note (SCC _) _) = False       -- See notes above
-exprIsTrivial (Note _       e) = exprIsTrivial e
+exprIsTrivial (Note _       e) = exprIsTrivial e  -- See Note [SCCs are trivial]
 exprIsTrivial (Cast e _)       = exprIsTrivial e
 exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
 exprIsTrivial _                = False
@@ -641,8 +676,6 @@ isDivOp IntQuotOp	 = True
 isDivOp IntRemOp	 = True
 isDivOp WordQuotOp	 = True
 isDivOp WordRemOp	 = True
-isDivOp IntegerQuotRemOp = True
-isDivOp IntegerDivModOp  = True
 isDivOp FloatDivOp       = True
 isDivOp DoubleDivOp      = True
 isDivOp _                = False