Implement the PushT rule from the FC paper

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

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 2dbabb8..acd0830 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -19,7 +19,7 @@ module SimplUtils (
        mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
        interestingCallContext, interestingArgContext,
 
-       interestingArg, isStrictBndr, mkArgInfo
+       interestingArg, mkArgInfo
     ) where
 
 #include "HsVersions.h"
@@ -216,6 +216,14 @@ interestingArg (Var v)              = hasSomeUnfolding (idUnfolding v)
 interestingArg (Type _)                 = False
 interestingArg (App fn (Type _)) = interestingArg fn
 interestingArg (Note _ a)       = interestingArg a
+
+-- Idea (from Sam B); I'm not sure if it's a good idea, so commented out for now
+-- interestingArg expr | isUnLiftedType (exprType expr)
+--        -- Unlifted args are only ever interesting if we know what they are
+--  =                  case expr of
+--                        Lit lit -> True
+--                        _       -> False
+
 interestingArg other            = True
        -- Consider     let x = 3 in f x
        -- The substitution will contain (x -> ContEx 3), and we want to
@@ -796,6 +804,14 @@ mkLam bndrs body
   = do { dflags <- getDOptsSmpl
        ; mkLam' dflags bndrs body }
   where
+    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
+    mkLam' dflags bndrs (Cast body@(Lam _ _) co)
+       -- Note [Casts and lambdas]
+      = do { lam <- mkLam' dflags (bndrs ++ bndrs') body'
+          ; return (mkCoerce (mkPiTypes bndrs co) lam) }
+      where    
+       (bndrs',body') = collectBinders body
+
     mkLam' dflags bndrs body
       | dopt Opt_DoEtaReduction dflags,
         Just etad_lam <- tryEtaReduce bndrs body
@@ -811,6 +827,21 @@ mkLam bndrs body
       = returnSmpl (mkLams bndrs body)
 \end{code}
 
+Note [Casts and lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider 
+       (\x. (\y. e) `cast` g1) `cast` g2
+There is a danger here that the two lambdas look separated, and the 
+full laziness pass might float an expression to between the two.
+
+So this equation in mkLam' floats the g1 out, thus:
+       (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)
+where x:tx.
+
+In general, this floats casts outside lambdas, where (I hope) they might meet
+and cancel with some other cast.
+
+
 --     c) floating lets out through big lambdas 
 --             [only if all tyvar lambdas, and only if this lambda
 --              is the RHS of a let]