X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=6ae9587e084d89ead882ed9aec97e34f0b5c702d;hb=f07f25fdbac2b885aea6aa62c0326840c85f7b59;hp=d2f6ebb38851c9d9e14ffbbb13bc1ae6b1fe5e71;hpb=483ab832e7f6dcdee13e6a5556be7c1ffc303a9f;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index d2f6ebb..6ae9587 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -18,6 +18,7 @@ import Id
 import MkId		( mkImpossibleExpr, seqId )
 import Var
 import IdInfo
+import Name		( mkSystemVarName )
 import Coercion
 import FamInstEnv       ( topNormaliseType )
 import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness )
@@ -337,7 +338,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
         -- Simplify the RHS
         ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
         -- ANF-ise a constructor or PAP rhs
-        ; (body_env2, body2) <- prepareRhs body_env1 body1
+        ; (body_env2, body2) <- prepareRhs body_env1 bndr1 body1
 
         ; (env', rhs')
             <-  if not (doFloatFromRhs top_lvl is_rec False body2 body_env2)
@@ -383,7 +384,7 @@ completeNonRecX :: SimplEnv
                 -> SimplM SimplEnv
 
 completeNonRecX env is_strict old_bndr new_bndr new_rhs
-  = do  { (env1, rhs1) <- prepareRhs (zapFloats env) new_rhs
+  = do  { (env1, rhs1) <- prepareRhs (zapFloats env) new_bndr new_rhs
         ; (env2, rhs2) <-
                 if doFloatFromRhs NotTopLevel NonRecursive is_strict rhs1 env1
                 then do { tick LetFloatFromLet
@@ -434,15 +435,19 @@ Here we want to make e1,e2 trivial and get
 That's what the 'go' loop in prepareRhs does
 
 \begin{code}
-prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
+prepareRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
 -- Adds new floats to the env iff that allows us to return a good RHS
-prepareRhs env (Cast rhs co)    -- Note [Float coercions]
+prepareRhs env id (Cast rhs co)    -- Note [Float coercions]
   | (ty1, _ty2) <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
   , not (isUnLiftedType ty1)            -- see Note [Float coercions (unlifted)]
-  = do  { (env', rhs') <- makeTrivial env rhs
+  = do  { (env', rhs') <- makeTrivialWithInfo env sanitised_info rhs
         ; return (env', Cast rhs' co) }
+  where
+    sanitised_info = vanillaIdInfo `setNewStrictnessInfo` newStrictnessInfo info
+                                   `setNewDemandInfo`     newDemandInfo info
+    info = idInfo id
 
-prepareRhs env0 rhs0
+prepareRhs env0 _ rhs0
   = do  { (_is_val, env1, rhs1) <- go 0 env0 rhs0
         ; return (env1, rhs1) }
   where
@@ -492,6 +497,17 @@ and lead to further optimisation.  Example:
           go n = case x of { T m -> go (n-m) }
                 -- This case should optimise
 
+Note [Preserve strictness when floating coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the Note [Float coercions] transformation, keep the strictness info.
+Eg
+	f = e `cast` co	   -- f has strictness SSL
+When we transform to
+        f' = e		   -- f' also has strictness SSL
+        f = f' `cast` co   -- f still has strictness SSL
+
+Its not wrong to drop it on the floor, but better to keep it.
+
 Note [Float coercions (unlifted)]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 BUT don't do [Float coercions] if 'e' has an unlifted type.
@@ -512,16 +528,19 @@ These strange casts can happen as a result of case-of-case
 \begin{code}
 makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
 -- Binds the expression to a variable, if it's not trivial, returning the variable
-makeTrivial env expr
+makeTrivial env expr = makeTrivialWithInfo env vanillaIdInfo expr
+
+makeTrivialWithInfo :: SimplEnv -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)
+-- Propagate strictness and demand info to the new binder
+-- Note [Preserve strictness when floating coercions]
+makeTrivialWithInfo env info expr
   | exprIsTrivial expr
   = return (env, expr)
   | otherwise           -- See Note [Take care] below
-  = do  { var <- newId (fsLit "a") (exprType expr)
+  = do  { uniq <- getUniqueM
+        ; let name = mkSystemVarName uniq (fsLit "a")
+              var = mkLocalIdWithInfo name (exprType expr) info
         ; env' <- completeNonRecX env False var var expr
---	  pprTrace "makeTrivial" (vcat [ppr var <+> ppr (exprArity (substExpr env' (Var var)))
---	  	   		       , ppr expr
---	  	   		       , ppr (substExpr env' (Var var))
---				       , ppr (idArity (fromJust (lookupInScope (seInScope env') var))) ]) $
 	; return (env', substExpr env' (Var var)) }
 	-- The substitution is needed becase we're constructing a new binding
 	--     a = rhs
@@ -923,14 +942,19 @@ simplCast env body co0 cont0
 
        add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
                 -- (f |> g) ty  --->   (f ty) |> (g @ ty)
-                -- This implements the PushT rule from the paper
+                -- This implements the PushT and PushC rules from the paper
          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
-         , not (isCoVar tyvar)
-         = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
+         = let 
+             (new_arg_ty, new_cast)
+               | isCoVar tyvar = (new_arg_co, mkCselRCoercion co)       -- PushC rule
+               | otherwise     = (ty',        mkInstCoercion co ty')    -- PushT rule
+           in 
+           ApplyTo dup (Type new_arg_ty) (zapSubstEnv env) (addCoerce new_cast cont)
          where
            ty' = substTy (arg_se `setInScope` env) arg_ty
-
-        -- ToDo: the PushC rule is not implemented at all
+	   new_arg_co = mkCsel1Coercion co  `mkTransCoercion`
+                              ty'           `mkTransCoercion`
+                        mkSymCoercion (mkCsel2Coercion co)
 
        add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
          | not (isTypeArg arg)  -- This implements the Push rule from the paper