Fix initialisation of strictness in the demand analyser

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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 0a1fdd2..179af4f 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -28,8 +28,9 @@ import CoreMonad      ( SimplifierSwitch(..), Tick(..) )
 import CoreSyn
 import Demand           ( isStrictDmd, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreSyn
 import Demand           ( isStrictDmd, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )

-import CoreUnfold       ( mkUnfolding, mkCoreUnfolding, mkInlineRule, 
-                          exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
+import CoreUnfold       ( mkUnfolding, mkCoreUnfolding
+                        , mkInlineUnfolding, mkSimpleUnfolding
+                        , exprIsConApp_maybe, callSiteInline, CallCtxt(..) )

 import CoreUtils
 import qualified CoreSubst
 import CoreArity       ( exprArity )
 import CoreUtils
 import qualified CoreSubst
 import CoreArity       ( exprArity )

@@ -321,7 +322,8 @@ simplLazyBind :: SimplEnv
               -> SimplM SimplEnv
 
 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
               -> SimplM SimplEnv
 
 simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se

-  = do  { let   rhs_env     = rhs_se `setInScope` env
+  = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
+    do  { let   rhs_env     = rhs_se `setInScope` env

                (tvs, body) = case collectTyBinders rhs of
                                (tvs, body) | not_lam body -> (tvs,body)
                                            | otherwise    -> ([], rhs)
                (tvs, body) = case collectTyBinders rhs of
                                (tvs, body) | not_lam body -> (tvs,body)
                                            | otherwise    -> ([], rhs)

@@ -386,7 +388,7 @@ completeNonRecX :: TopLevelFlag -> SimplEnv
 
 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
   = do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs
 
 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
   = do  { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs

-        ; (env2, rhs2) <-
+        ; (env2, rhs2) <- 

                 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
                 then do { tick LetFloatFromLet
                         ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env
                 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
                 then do { tick LetFloatFromLet
                         ; return (addFloats env env1, rhs1) }   -- Add the floats to the main env

@@ -546,7 +548,7 @@ makeTrivialWithInfo top_lvl env info expr
   = do  { uniq <- getUniqueM
         ; let name = mkSystemVarName uniq (fsLit "a")
               var = mkLocalIdWithInfo name expr_ty info
   = do  { uniq <- getUniqueM
         ; let name = mkSystemVarName uniq (fsLit "a")
               var = mkLocalIdWithInfo name expr_ty info

-        ; env' <- completeNonRecX top_lvl env False var var expr
+        ; env'  <- completeNonRecX top_lvl env False var var expr

        ; expr' <- simplVar env' var
         ; return (env', expr') }
        -- The simplVar is needed becase we're constructing a new binding
        ; expr' <- simplVar env' var
         ; return (env', expr') }
        -- The simplVar is needed becase we're constructing a new binding

@@ -713,18 +715,33 @@ simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
 simplUnfolding env top_lvl id _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_src = src, uf_guidance = guide })
 simplUnfolding env top_lvl id _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_src = src, uf_guidance = guide })

-  | isInlineRuleSource src
+  | isStableSource src

   = do { expr' <- simplExpr rule_env expr
        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
   = do { expr' <- simplExpr rule_env expr
        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src

-       ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
+             is_top_lvl = isTopLevel top_lvl
+       ; case guide of
+           UnfIfGoodArgs{} ->
+              -- We need to force bottoming, or the new unfolding holds
+              -- on to the old unfolding (which is part of the id).
+              let bottoming = isBottomingId id
+              in bottoming `seq` return (mkUnfolding src' is_top_lvl bottoming expr')
+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
+                -- unfolding, and we need to make sure the guidance is kept up
+                -- to date with respect to any changes in the unfolding.
+           _other -> 
+              return (mkCoreUnfolding src' is_top_lvl expr' arity guide)

                -- See Note [Top-level flag on inline rules] in CoreUnfold
                -- See Note [Top-level flag on inline rules] in CoreUnfold

+       }

   where
     act      = idInlineActivation id
     rule_env = updMode (updModeForInlineRules act) env
   where
     act      = idInlineActivation id
     rule_env = updMode (updModeForInlineRules act) env

-                      -- See Note [Simplifying gently inside InlineRules] in SimplUtils
+                      -- See Note [Simplifying inside InlineRules] in SimplUtils

 
 simplUnfolding _ top_lvl id _occ_info new_rhs _
 
 simplUnfolding _ top_lvl id _occ_info new_rhs _

-  = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
+  = -- We need to force bottoming, or the new unfolding holds
+    -- on to the old unfolding (which is part of the id).
+    let bottoming = isBottomingId id
+    in bottoming `seq` return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs)

   -- We make an  unfolding *even for loop-breakers*.
   -- Reason: (a) It might be useful to know that they are WHNF
   --        (b) In TidyPgm we currently assume that, if we want to
   -- We make an  unfolding *even for loop-breakers*.
   -- Reason: (a) It might be useful to know that they are WHNF
   --        (b) In TidyPgm we currently assume that, if we want to

@@ -895,10 +912,9 @@ simplExprF' env (Case scrut bndr _ alts) cont
   | otherwise
   =     -- If case-of-case is off, simply simplify the case expression
         -- in a vanilla Stop context, and rebuild the result around it
   | otherwise
   =     -- If case-of-case is off, simply simplify the case expression
         -- in a vanilla Stop context, and rebuild the result around it

-    do  { case_expr' <- simplExprC env scrut case_cont
+    do  { case_expr' <- simplExprC env scrut
+                             (Select NoDup bndr alts env mkBoringStop)

         ; rebuild env case_expr' cont }
         ; rebuild env case_expr' cont }

-  where
-    case_cont = Select NoDup bndr alts env mkBoringStop

 
 simplExprF' env (Let (Rec pairs) body) cont
   = do  { env' <- simplRecBndrs env (map fst pairs)
 
 simplExprF' env (Let (Rec pairs) body) cont
   = do  { env' <- simplRecBndrs env (map fst pairs)

@@ -950,7 +966,9 @@ rebuild env expr cont0
       StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
                                          ; simplLam env' bs body cont }
       StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
                                          ; simplLam env' bs body cont }

-      ApplyTo _ arg se cont        -> do { arg' <- simplExpr (se `setInScope` env) arg
+      ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
+        | isSimplified dup_flag    -> rebuild env (App expr arg) cont
+        | otherwise                -> do { arg' <- simplExpr (se `setInScope` env) arg

                                          ; rebuild env (App expr arg') cont }
 \end{code}
 
                                          ; rebuild env (App expr arg') cont }
 \end{code}
 

@@ -1088,7 +1106,8 @@ simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
   | preInlineUnconditionally env NotTopLevel bndr rhs
   = do  { tick (PreInlineUnconditionally bndr)
 simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
   | preInlineUnconditionally env NotTopLevel bndr rhs
   = do  { tick (PreInlineUnconditionally bndr)

-        ; simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
+        ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
+          simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }

 
   | isStrictId bndr
   = do  { simplExprF (rhs_se `setFloats` env) rhs
 
   | isStrictId bndr
   = do  { simplExprF (rhs_se `setFloats` env) rhs

@@ -1236,7 +1255,10 @@ rebuildCall env info (ApplyTo _ (Type arg_ty) se cont)
 
 rebuildCall env info@(ArgInfo { ai_encl = encl_rules
                               , ai_strs = str:strs, ai_discs = disc:discs })
 
 rebuildCall env info@(ArgInfo { ai_encl = encl_rules
                               , ai_strs = str:strs, ai_discs = disc:discs })

-            (ApplyTo _ arg arg_se cont)
+            (ApplyTo dup_flag arg arg_se cont)
+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
+  = rebuildCall env (addArgTo info' arg) cont
+

   | str                -- Strict argument
   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
     simplExprF (arg_se `setFloats` env) arg
   | str                -- Strict argument
   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
     simplExprF (arg_se `setFloats` env) arg

@@ -1265,7 +1287,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules })
        ; mb_rule <- tryRules env rules fun args cont
        ; case mb_rule of {
             Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $
        ; mb_rule <- tryRules env rules fun args cont
        ; case mb_rule of {
             Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $

-                                        pushArgs env' (drop n_args args) cont ;
+                                        pushSimplifiedArgs env' (drop n_args args) cont ;

                  -- n_args says how many args the rule consumed
            ; Nothing -> rebuild env (mkApps (Var fun) args) cont      -- No rules
     } }
                  -- n_args says how many args the rule consumed
            ; Nothing -> rebuild env (mkApps (Var fun) args) cont      -- No rules
     } }

@@ -1276,7 +1298,7 @@ Note [RULES apply to simplified arguments]
 It's very desirable to try RULES once the arguments have been simplified, because
 doing so ensures that rule cascades work in one pass.  Consider
    {-# RULES g (h x) = k x
 It's very desirable to try RULES once the arguments have been simplified, because
 doing so ensures that rule cascades work in one pass.  Consider
    {-# RULES g (h x) = k x

-            f (k x) = x #-}
+             f (k x) = x #-}

    ...f (g (h x))...
 Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
 we match f's rules against the un-simplified RHS, it won't match.  This 
    ...f (g (h x))...
 Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
 we match f's rules against the un-simplified RHS, it won't match.  This 

@@ -1284,6 +1306,15 @@ makes a particularly big difference when superclass selectors are involved:
        op ($p1 ($p2 (df d)))
 We want all this to unravel in one sweeep.
 
        op ($p1 ($p2 (df d)))
 We want all this to unravel in one sweeep.
 

+Note [Avoid redundant simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because RULES apply to simplified arguments, there's a danger of repeatedly
+simplifying already-simplified arguments.  An important example is that of
+           (>>=) d e1 e2
+Here e1, e2 are simplified before the rule is applied, but don't really
+participate in the rule firing. So we mark them as Simplified to avoid
+re-simplifying them.
+

 Note [Shadowing]
 ~~~~~~~~~~~~~~~~
 This part of the simplifier may break the no-shadowing invariant
 Note [Shadowing]
 ~~~~~~~~~~~~~~~~
 This part of the simplifier may break the no-shadowing invariant

@@ -1789,7 +1820,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
 
 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
 addBinderUnfolding env bndr rhs
 
 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
 addBinderUnfolding env bndr rhs

-  = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
+  = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs)

 
 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
 addBinderOtherCon env bndr cons
 
 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
 addBinderOtherCon env bndr cons

@@ -2016,7 +2047,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
                      DataAlt dc -> setIdUnfolding case_bndr unf
                          where
                                 -- See Note [Case binders and join points]
                      DataAlt dc -> setIdUnfolding case_bndr unf
                          where
                                 -- See Note [Case binders and join points]

-                            unf = mkInlineRule rhs Nothing
+                            unf = mkInlineUnfolding Nothing rhs

                             rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
                                                ++ varsToCoreExprs bndrs')
 
                             rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
                                                ++ varsToCoreExprs bndrs')
 

@@ -2243,7 +2274,7 @@ The desire not to duplicate is the entire reason that
 mkDupableCont returns a pair of continuations.
 
 
 mkDupableCont returns a pair of continuations.
 
 

-Note [Single-atlernative cases]
+Note [Single-alternative cases]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 This case is just like the ArgOf case.  Here's an example:
         data T a = MkT !a
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 This case is just like the ArgOf case.  Here's an example:
         data T a = MkT !a