X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=c33bc3d90c8dc4b7813175be24909dacad214e23;hb=27061b5b4008a831eba4784358b040bb1250dcef;hp=724612efe37dd72a16ee4e70e86626ceca9b401f;hpb=fa1c8a7e7013b1e9a37326b80abadec737c9347e;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 724612e..c33bc3d 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -58,6 +58,7 @@ import BasicTypes
 import Util
 import MonadUtils
 import Outputable
+import FastString
 
 import List( nub )
 \end{code}
@@ -352,6 +353,11 @@ mkArgInfo :: Id
 	  -> ArgInfo
 
 mkArgInfo fun n_val_args call_cont
+  | n_val_args < idArity fun		-- Note [Unsaturated functions]
+  = ArgInfo { ai_rules = False
+	    , ai_strs = vanilla_stricts 
+	    , ai_discs = vanilla_discounts }
+  | otherwise
   = ArgInfo { ai_rules = interestingArgContext fun call_cont
 	    , ai_strs  = arg_stricts
 	    , ai_discs = arg_discounts }
@@ -382,7 +388,20 @@ mkArgInfo fun n_val_args call_cont
 		   else
 			map isStrictDmd demands ++ vanilla_stricts
 
-	  other -> vanilla_stricts	-- Not enough args, or no strictness
+	       | otherwise
+	       -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) 
+				<+> ppr n_val_args <+> ppr demands ) 
+		   vanilla_stricts	-- Not enough args, or no strictness
+
+{- Note [Unsaturated functions]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (test eyeball/inline4)
+	x = a:as
+	y = f x
+where f has arity 2.  Then we do not want to inline 'x', because
+it'll just be floated out again.  Even if f has lots of discounts
+on its first argument -- it must be saturated for these to kick in
+-}
 
 interestingArgContext :: Id -> SimplCont -> Bool
 -- If the argument has form (f x y), where x,y are boring,
@@ -433,7 +452,7 @@ settings:
 			(d) Simplifying a GHCi expression or Template 
 				Haskell splice
 
-	SimplPhase n	Used at all other times
+	SimplPhase n _	 Used at all other times
 
 The key thing about SimplGently is that it does no call-site inlining.
 Before full laziness we must be careful not to inline wrappers,
@@ -582,8 +601,8 @@ preInlineUnconditionally env top_lvl bndr rhs
   where
     phase = getMode env
     active = case phase of
-		   SimplGently  -> isAlwaysActive prag
-		   SimplPhase n -> isActive n prag
+		   SimplGently    -> isAlwaysActive prag
+		   SimplPhase n _ -> isActive n prag
     prag = idInlinePragma bndr
 
     try_once in_lam int_cxt	-- There's one textual occurrence
@@ -617,8 +636,8 @@ preInlineUnconditionally env top_lvl bndr rhs
     canInlineInLam _			= False
 
     early_phase = case phase of
-			SimplPhase 0 -> False
-			other	     -> True
+			SimplPhase 0 _ -> False
+			other	       -> True
 -- If we don't have this early_phase test, consider
 --	x = length [1,2,3]
 -- The full laziness pass carefully floats all the cons cells to
@@ -738,8 +757,8 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 
   where
     active = case getMode env of
-		   SimplGently  -> isAlwaysActive prag
-		   SimplPhase n -> isActive n prag
+		   SimplGently    -> isAlwaysActive prag
+		   SimplPhase n _ -> isActive n prag
     prag = idInlinePragma bndr
 
 activeInline :: SimplEnv -> OutId -> Bool
@@ -747,7 +766,7 @@ activeInline env id
   = case getMode env of
       SimplGently -> False
 	-- No inlining at all when doing gentle stuff,
-	-- except for local things that occur once
+	-- except for local things that occur once (pre/postInlineUnconditionally)
 	-- The reason is that too little clean-up happens if you 
 	-- don't inline use-once things.   Also a bit of inlining is *good* for
 	-- full laziness; it can expose constant sub-expressions.
@@ -761,7 +780,7 @@ activeInline env id
 	-- and they are now constructed as Compulsory unfoldings (in MkId)
 	-- so they'll happen anyway.
 
-      SimplPhase n -> isActive n prag
+      SimplPhase n _ -> isActive n prag
   where
     prag = idInlinePragma id
 
@@ -772,13 +791,13 @@ activeRule dflags env
   = Nothing	-- Rewriting is off
   | otherwise
   = case getMode env of
-	SimplGently  -> Just isAlwaysActive
+	SimplGently    -> Just isAlwaysActive
 			-- Used to be Nothing (no rules in gentle mode)
 			-- Main motivation for changing is that I wanted
 			-- 	lift String ===> ...
 			-- to work in Template Haskell when simplifying
 			-- splices, so we get simpler code for literal strings
-	SimplPhase n -> Just (isActive n)
+	SimplPhase n _ -> Just (isActive n)
 \end{code}
 
 
@@ -1146,7 +1165,8 @@ abstractFloats main_tvs body_env body
       = do { uniq <- getUniqueM
 	   ; let  poly_name = setNameUnique (idName var) uniq		-- Keep same name
 		  poly_ty   = mkForAllTys tvs_here (idType var)	-- But new type of course
-		  poly_id   = mkLocalId poly_name poly_ty 
+		  poly_id   = transferPolyIdInfo var $ 	-- Note [transferPolyIdInfo] in Id.lhs
+			      mkLocalId poly_name poly_ty 
 	   ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
 		-- In the olden days, it was crucial to copy the occInfo of the original var, 
 		-- because we were looking at occurrence-analysed but as yet unsimplified code!