X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=7c88ad29e8c716340a03a13c5e4073cc526d7135;hb=63f6b0868f4948232f87bc4df52c9d3a2ec8f184;hp=10965a18455cfb3e03619b9b206cd1e5e05f7e9b;hpb=62eeda5aed31173b234b2965ccf4bd6979ffd9a4;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 10965a1..7c88ad2 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -461,7 +461,7 @@ prepareRhs env0 rhs0
         where
           is_val = n_val_args > 0       -- There is at least one arg
                                         -- ...and the fun a constructor or PAP
-                 && (isDataConWorkId fun || n_val_args < idArity fun)
+                 && (isConLikeId fun || n_val_args < idArity fun)
     go _ env other
         = return (False, env, other)
 \end{code}
@@ -578,7 +578,7 @@ completeBind env top_lvl old_bndr new_bndr new_rhs
   = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr)
   where
     unfolding | omit_unfolding = NoUnfolding
-	      | otherwise      = mkUnfolding  (isTopLevel top_lvl) new_rhs
+	      | otherwise      = mkUnfolding (isTopLevel top_lvl) new_rhs
     old_info    = idInfo old_bndr
     occ_info    = occInfo old_info
     wkr		= substWorker env (workerInfo old_info)
@@ -623,7 +623,9 @@ addNonRecWithUnf :: SimplEnv
 addNonRecWithUnf env new_bndr rhs unfolding wkr
   = ASSERT( isId new_bndr )
     WARN( new_arity < old_arity || new_arity < dmd_arity, 
-          (ppr final_id <+> ppr old_arity <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
+          (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity
+		<+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs )
+	-- Note [Arity decrease]
     final_id `seq`      -- This seq forces the Id, and hence its IdInfo,
 	                -- and hence any inner substitutions
     addNonRec env final_id rhs
@@ -666,6 +668,28 @@ addNonRecWithUnf env new_bndr rhs unfolding wkr
         final_id = new_bndr `setIdInfo` final_info
 \end{code}
 
+Note [Arity decrease]
+~~~~~~~~~~~~~~~~~~~~~
+Generally speaking the arity of a binding should not decrease.  But it *can* 
+legitimately happen becuase of RULES.  Eg
+	f = g Int
+where g has arity 2, will have arity 2.  But if there's a rewrite rule
+	g Int --> h
+where h has arity 1, then f's arity will decrease.  Here's a real-life example,
+which is in the output of Specialise:
+
+     Rec {
+	$dm {Arity 2} = \d.\x. op d
+	{-# RULES forall d. $dm Int d = $s$dm #-}
+	
+	dInt = MkD .... opInt ...
+	opInt {Arity 1} = $dm dInt
+
+	$s$dm {Arity 0} = \x. op dInt }
+
+Here opInt has arity 1; but when we apply the rule its arity drops to 0.
+That's why Specialise goes to a little trouble to pin the right arity
+on specialised functions too.
 
 
 %************************************************************************
@@ -1763,11 +1787,20 @@ mkDupableCont env (CoerceIt ty cont)
 
 mkDupableCont env cont@(StrictBind {})
   =  return (env, mkBoringStop, cont)
-        -- See Note [Duplicating strict continuations]
+        -- See Note [Duplicating StrictBind]
 
-mkDupableCont env cont@(StrictArg {})
-  =  return (env, mkBoringStop, cont)
-        -- See Note [Duplicating strict continuations]
+mkDupableCont env (StrictArg fun cci ai cont)
+        -- See Note [Duplicating StrictArg]
+  = do { (env', dup, nodup) <- mkDupableCont env cont
+       ; (env'', fun') <- mk_dupable_call env' fun
+       ; return (env'', StrictArg fun' cci ai dup, nodup) }
+  where
+    mk_dupable_call env (Var v)       = return (env, Var v)
+    mk_dupable_call env (App fun arg) = do { (env', fun') <- mk_dupable_call env fun
+                                           ; (env'', arg') <- makeTrivial env' arg
+                                           ; return (env'', fun' `App` arg') }
+    mk_dupable_call _ other = pprPanic "mk_dupable_call" (ppr other)
+	-- The invariant of StrictArg is that the first arg is always an App chain
 
 mkDupableCont env (ApplyTo _ arg se cont)
   =     -- e.g.         [...hole...] (...arg...)
@@ -1948,32 +1981,71 @@ It's a bit silly to add the realWorld dummy arg in this case, making
            True -> $j s
 (the \v alone is enough to make CPR happy) but I think it's rare
 
-Note [Duplicating strict continuations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Do *not* duplicate StrictBind and StritArg continuations.  We gain
-nothing by propagating them into the expressions, and we do lose a
-lot.  Here's an example:
-        && (case x of { T -> F; F -> T }) E
+Note [Duplicating StrictArg]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The original plan had (where E is a big argument)
+e.g.    f E [..hole..]
+        ==>     let $j = \a -> f E a
+                in $j [..hole..]
+
+But this is terrible! Here's an example:
+        && E (case x of { T -> F; F -> T })
 Now, && is strict so we end up simplifying the case with
 an ArgOf continuation.  If we let-bind it, we get
-
-        let $j = \v -> && v E
+        let $j = \v -> && E v
         in simplExpr (case x of { T -> F; F -> T })
                      (ArgOf (\r -> $j r)
 And after simplifying more we get
-
-        let $j = \v -> && v E
+        let $j = \v -> && E v
         in case x of { T -> $j F; F -> $j T }
 Which is a Very Bad Thing
 
+What we do now is this
+	f E [..hole..]
+ 	==> 	let a = E
+		in f a [..hole..]
+Now if the thing in the hole is a case expression (which is when
+we'll call mkDupableCont), we'll push the function call into the
+branches, which is what we want.  Now RULES for f may fire, and
+call-pattern specialisation.  Here's an example from Trac #3116
+     go (n+1) (case l of
+           	 1  -> bs'
+           	 _  -> Chunk p fpc (o+1) (l-1) bs')
+If we can push the call for 'go' inside the case, we get
+call-pattern specialisation for 'go', which is *crucial* for 
+this program.
+
+Here is the (&&) example: 
+        && E (case x of { T -> F; F -> T })
+  ==>   let a = E in 
+        case x of { T -> && a F; F -> && a T }
+Much better!
+
+Notice that 
+  * Arguments to f *after* the strict one are handled by 
+    the ApplyTo case of mkDupableCont.  Eg
+	f [..hole..] E
+
+  * We can only do the let-binding of E because the function
+    part of a StrictArg continuation is an explicit syntax
+    tree.  In earlier versions we represented it as a function
+    (CoreExpr -> CoreEpxr) which we couldn't take apart.
+
+Do *not* duplicate StrictBind and StritArg continuations.  We gain
+nothing by propagating them into the expressions, and we do lose a
+lot.  
+
+The desire not to duplicate is the entire reason that
+mkDupableCont returns a pair of continuations.
+
+Note [Duplicating StrictBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unlike StrictArg, there doesn't seem anything to gain from
+duplicating a StrictBind continuation, so we don't.
+
 The desire not to duplicate is the entire reason that
 mkDupableCont returns a pair of continuations.
 
-The original plan had:
-e.g.    (...strict-fn...) [...hole...]
-        ==>
-                let $j = \a -> ...strict-fn...
-                in $j [...hole...]
 
 Note [Single-alternative cases]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~