X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=e8714d486a48b685bd6bd9bec7d6c96247c2685a;hb=cc51a698c0938edaa3ccc95db19150bbaec6f795;hp=8acf9134e3f8fadb47012a978ba5bc8ac84d3cac;hpb=65b5fb0ff8dd2af5c8bed6db5f059b4f60eb05de;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 8acf913..e8714d4 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -4,6 +4,13 @@
 \section[SimplUtils]{The simplifier utilities}
 
 \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 SimplUtils (
 	-- Rebuilding
 	mkLam, mkCase, prepareAlts, bindCaseBndr,
@@ -15,7 +22,7 @@ module SimplUtils (
 	-- The continuation type
 	SimplCont(..), DupFlag(..), LetRhsFlag(..), 
 	contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
-	countValArgs, countArgs,
+	countValArgs, countArgs, splitInlineCont,
 	mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
 	interestingCallContext, interestingArgContext,
 
@@ -39,9 +46,11 @@ import CoreUnfold
 import MkId
 import Name
 import Id
+import Var	( isCoVar )
 import NewDemand
 import SimplMonad
-import Type
+import Type	( Type, funArgTy, mkForAllTys, mkTyVarTys, 
+		  splitTyConApp_maybe, tyConAppArgs )
 import TyCon
 import DataCon
 import Unify	( dataConCannotMatch )
@@ -153,10 +162,11 @@ mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules)
 mkRhsStop :: OutType -> SimplCont
 mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
 
-contIsRhsOrArg (Stop {})       = True
-contIsRhsOrArg (StrictBind {}) = True
-contIsRhsOrArg (StrictArg {})  = True
-contIsRhsOrArg other	       = False
+-------------------
+contIsRhsOrArg (Stop {})       	 = True
+contIsRhsOrArg (StrictBind {}) 	 = True
+contIsRhsOrArg (StrictArg {})  	 = True
+contIsRhsOrArg other	         = False
 
 -------------------
 contIsDupable :: SimplCont -> Bool
@@ -203,6 +213,26 @@ dropArgs :: Int -> SimplCont -> SimplCont
 dropArgs 0 cont = cont
 dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
 dropArgs n other		= pprPanic "dropArgs" (ppr n <+> ppr other)
+
+--------------------
+splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont)
+-- Returns Nothing if the continuation should dissolve an InlineMe Note
+-- Return Just (c1,c2) otherwise, 
+--	where c1 is the continuation to put inside the InlineMe 
+--	and   c2 outside
+
+-- Example: (__inline_me__ (/\a. e)) ty
+--	Here we want to do the beta-redex without dissolving the InlineMe
+-- See test simpl017 (and Trac #1627) for a good example of why this is important
+
+splitInlineCont (ApplyTo dup (Type ty) se c)
+  | Just (c1, c2) <- splitInlineCont c 	        = Just (ApplyTo dup (Type ty) se c1, c2)
+splitInlineCont cont@(Stop ty _ _)       	= Just (mkBoringStop ty, cont)
+splitInlineCont cont@(StrictBind bndr _ _ se _) = Just (mkBoringStop (substTy se (idType bndr)), cont)
+splitInlineCont cont@(StrictArg _ fun_ty _ _)   = Just (mkBoringStop (funArgTy fun_ty), cont)
+splitInlineCont other				= Nothing
+	-- NB: the calculation of the type for mkBoringStop is an annoying
+	--     duplication of the same calucation in mkDupableCont
 \end{code}
 
 
@@ -1041,8 +1071,11 @@ abstractFloats main_tvs body_env body
 		 subst'   = CoreSubst.extendIdSubst subst id poly_app
 	   ; return (subst', (NonRec poly_id poly_rhs)) }
       where
-	rhs'     = CoreSubst.substExpr subst rhs
-	tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+	rhs' = CoreSubst.substExpr subst rhs
+	tvs_here | any isCoVar main_tvs = main_tvs	-- Note [Abstract over coercions]
+		 | otherwise 
+		 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+	
 		-- Abstract only over the type variables free in the rhs
 		-- wrt which the new binding is abstracted.  But the naive
 		-- approach of abstract wrt the tyvars free in the Id's type
@@ -1101,6 +1134,13 @@ abstractFloats main_tvs body_env body
 		-- pinned on x.
 \end{code}
 
+Note [Abstract over coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
+type variable a.  Rather than sort this mess out, we simply bale out and abstract
+wrt all the type variables if any of them are coercion variables.
+
+
 Historical note: if you use let-bindings instead of a substitution, beware of this:
 
 		-- Suppose we start with: