Transfer strictness and arity info when abstracting over type variables

[ghc-hetmet.git] / compiler / simplCore / SimplUtils.lhs

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 724612e..c33bc3d 100644 (file)
--- 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!