Haskell Program Coverage

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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 404a77f..b3e6bf7 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -911,6 +911,14 @@ simplNote env InlineMe e cont
 simplNote env (CoreNote s) e cont
   = simplExpr env e    `thenSmpl` \ e' ->
     rebuild env (Note (CoreNote s) e') cont
+
+simplNote env note@(TickBox {}) e cont
+  = simplExpr env e    `thenSmpl` \ e' ->
+    rebuild env (Note note e') cont
+
+simplNote env note@(BinaryTickBox {}) e cont
+  = simplExpr env e    `thenSmpl` \ e' ->
+    rebuild env (Note note e') cont
 \end{code}
 
 
@@ -1014,7 +1022,7 @@ completeCall env var cont
                (if dopt Opt_D_dump_inlinings dflags then
                   pprTrace "Inlining done" (vcat [
                        text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
-                       text "Inlined fn: " <+> ppr unfolding,
+                       text "Inlined fn: " $$ nest 2 (ppr unfolding),
                        text "Cont:  " <+> ppr call_cont])
                 else
                        id)             $
@@ -1195,10 +1203,12 @@ mkAtomicArgsE :: SimplEnv
              -> SimplM FloatsWithExpr
 
 mkAtomicArgsE env is_strict (Cast rhs co) thing_inside
+  | not (exprIsTrivial rhs)
        -- Note [Float coersions]
+       -- See also Note [Take care] below
   = do { id <- newId FSLIT("a") (exprType rhs)
        ; completeNonRecX env False id id rhs $ \ env ->
-         thing_inside env (Cast (Var id) co) }
+         thing_inside env (Cast (substExpr env (Var id)) co) }
 
 mkAtomicArgsE env is_strict rhs thing_inside
   | (Var fun, args) <- collectArgs rhs,                                -- It's an application
@@ -1218,7 +1228,18 @@ mkAtomicArgsE env is_strict rhs thing_inside
        | otherwise
        = do { arg_id <- newId FSLIT("a") arg_ty
             ; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env ->
-              go env (App fun (Var arg_id)) args }
+              go env (App fun (substExpr env (Var arg_id))) args }
+               -- Note [Take care]:
+               -- If completeNonRecX was to do a postInlineUnconditionally
+               -- (undoing the effect of introducing the let-binding), we'd find arg_id had
+               -- no binding; hence the substExpr.  This happens if we see
+               --      C (D x `cast` g)
+               -- Then we start by making a variable a1, thus
+               --      let a1 = D x `cast` g in C a1
+               -- But then we deal with the rhs of a1, getting
+               --      let a2 = D x, a1 = a1 `cast` g in C a1
+               -- And now the preInlineUnconditionally kicks in, and we substitute for a1
+       
        where
          arg_ty = exprType arg
          no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
@@ -1233,6 +1254,7 @@ mkAtomicArgs :: Bool      -- OK to float unlifted args
                                                  -- if the strict-binding flag is on
 
 mkAtomicArgs ok_float_unlifted (Cast rhs co)
+  | not (exprIsTrivial rhs)
        -- Note [Float coersions]
   = do { id <- newId FSLIT("a") (exprType rhs)
        ; (binds, rhs') <- mkAtomicArgs ok_float_unlifted rhs