X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=1c08d6bf2843843af8fe1deedd658d561c5becae;hb=0c658578d609f93a25a8dff97b5cead055b246e3;hp=dd4cec6bc80d99a98dfa7604ec8b63b714e1c073;hpb=76dfa3944cbf149a30398d29e6762a44772c0174;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index dd4cec6..1c08d6b 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -28,6 +28,7 @@ module SimplUtils (
 #include "HsVersions.h"
 
 import SimplEnv
+import CoreMonad	( SimplifierMode(..), Tick(..) )
 import DynFlags
 import StaticFlags
 import CoreSyn
@@ -146,8 +147,8 @@ instance Outputable SimplCont where
 					  {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
   ppr (StrictBind b _ _ _ cont)      = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
   ppr (StrictArg ai _ cont)          = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
-  ppr (Select dup bndr alts _ cont)  = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ 
-				       (nest 4 (ppr alts)) $$ ppr cont 
+  ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ 
+				       (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont 
   ppr (CoerceIt co cont)	     = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
 
 data DupFlag = OkToDup | NoDup
@@ -221,12 +222,21 @@ countArgs :: SimplCont -> Int
 countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont
 countArgs _                    = 0
 
-contArgs :: SimplCont -> ([OutExpr], SimplCont)
+contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
 -- Uses substitution to turn each arg into an OutExpr
-contArgs cont = go [] cont
+contArgs cont@(ApplyTo {})
+  = case go [] cont of { (args, cont') -> (False, args, cont') }
   where
-    go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
-    go args cont		    = (reverse args, cont)
+    go args (ApplyTo _ arg se cont)
+      | isTypeArg arg = go args                           cont
+      | otherwise     = go (is_interesting arg se : args) cont
+    go args cont      = (reverse args, cont)
+
+    is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg)
+    		   -- Do *not* use short-cutting substitution here
+		   -- because we want to get as much IdInfo as possible
+
+contArgs cont = (True, [], cont)
 
 pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
 pushArgs _env []         cont = cont
@@ -601,15 +611,13 @@ updModeForInlineRules inline_rule_act current_mode
       ActiveBefore {} -> mk_gentle current_mode
       ActiveAfter n   -> mk_phase n current_mode
   where
-    no_op  = SimplGently { sm_rules = False, sm_inline = False }
+    no_op = SimplGently { sm_rules = False, sm_inline = False }
 
     mk_gentle (SimplGently {}) = current_mode
-    mk_gentle _                = SimplGently { sm_rules = True,  sm_inline = True }
+    mk_gentle _                = SimplGently { sm_rules = True, sm_inline = True }
 
-    mk_phase n (SimplPhase cp ss) 
-                    | cp > n    = no_op	-- Current phase earlier than n
-                    | otherwise = SimplPhase n ss
-    mk_phase _ (SimplGently {}) = no_op
+    mk_phase n (SimplPhase _ ss) = SimplPhase n ss
+    mk_phase n (SimplGently {})  = SimplPhase n ["gentle-rules"]
 \end{code}
 
 
@@ -1000,8 +1008,9 @@ mkLam env bndrs body
 
       | dopt Opt_DoLambdaEtaExpansion dflags,
         not (inGentleMode env),	      -- In gentle mode don't eta-expansion
-   	any isRuntimeVar bndrs	      -- because it can clutter up the code
+	    		  	      -- because it can clutter up the code
 	    		 	      -- with casts etc that may not be removed
+   	not (all isTyVar bndrs) -- Don't eta expand type abstractions
       = do { let body' = tryEtaExpansion dflags body
  	   ; return (mkLams bndrs body') }
    
@@ -1283,7 +1292,7 @@ abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExp
 abstractFloats main_tvs body_env body
   = ASSERT( notNull body_floats )
     do	{ (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
-	; return (float_binds, CoreSubst.substExpr subst body) }
+	; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
   where
     main_tv_set = mkVarSet main_tvs
     body_floats = getFloats body_env
@@ -1296,7 +1305,7 @@ 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
+	rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
 	tvs_here | any isCoVar main_tvs = main_tvs	-- Note [Abstract over coercions]
 		 | otherwise 
 		 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
@@ -1320,7 +1329,8 @@ abstractFloats main_tvs body_env body
     abstract subst (Rec prs)
        = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
 	    ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
-		  poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
+		  poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs) 
+                              | rhs <- rhss]
 	    ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
        where
 	 (ids,rhss) = unzip prs