Correct the float-coercions-out-of-let patch

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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index c59de9f..db08df6 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1152,7 +1152,6 @@ N  Y      Non-top-level and non-recursive,        Bind args of lifted type, or
 Y  Y   Non-top-level, non-recursive,           Bind all args
                 and strict (demanded)
        
-
 For example, given
 
        x = MkC (y div# z)
@@ -1165,13 +1164,44 @@ because the (y div# z) can't float out of the let. But if it was
 a *strict* let, then it would be a good thing to do.  Hence the
 context information.
 
+Note [Float coercions]
+~~~~~~~~~~~~~~~~~~~~~~
+When we find the binding
+       x = e `cast` co
+we'd like to transform it to
+       x' = e
+       x = x `cast` co         -- A trivial binding
+There's a chance that e will be a constructor application or function, or something
+like that, so moving the coerion to the usage site may well cancel the coersions
+and lead to further optimisation.  Example:
+
+     data family T a :: *
+     data instance T Int = T Int
+
+     foo :: Int -> Int -> Int
+     foo m n = ...
+        where
+          x = T m
+          go 0 = 0
+          go n = case x of { T m -> go (n-m) }
+               -- This case should optimise
+
 \begin{code}
 mkAtomicArgsE :: SimplEnv 
-             -> Bool   -- A strict binding
-             -> OutExpr                                                -- The rhs
+             -> Bool           -- A strict binding
+             -> OutExpr        -- The rhs
              -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
+                               -- Consumer for the simpler rhs
              -> 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) }
+
 mkAtomicArgsE env is_strict rhs thing_inside
   | (Var fun, args) <- collectArgs rhs,                                -- It's an application
     isDataConWorkId fun || valArgCount args < idArity fun      -- And it's a constructor or PAP
@@ -1191,6 +1221,10 @@ mkAtomicArgsE env is_strict rhs thing_inside
        = 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 }
+               -- Note [Take care]:
+               -- This is sightly delicate.  If completeNonRecX was to do a postInlineUnconditionally
+               -- (undoing the effect of introducing the let-binding), we'd find arg_id had
+               -- no binding.   The exprIsTrivial is the only time that'll happen, though.
        where
          arg_ty = exprType arg
          no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
@@ -1204,6 +1238,13 @@ mkAtomicArgs :: Bool     -- OK to float unlifted args
                        OutExpr)                  -- things that need case-binding,
                                                  -- 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
+       ; return (binds `snocOL` (id, rhs'), Cast (Var id) co) }
+
 mkAtomicArgs ok_float_unlifted rhs
   | (Var fun, args) <- collectArgs rhs,                                -- It's an application
     isDataConWorkId fun || valArgCount args < idArity fun      -- And it's a constructor or PAP