Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/d2729dc2f7d68838922dfb2c2399a57c96669d93 >--------------------------------------------------------------- commit d2729dc2f7d68838922dfb2c2399a57c96669d93 Author: Simon Marlow <[email protected]> Date: Mon Nov 14 14:59:37 2011 +0000 wrapTick: don't wrap HNFs (see comment) >--------------------------------------------------------------- compiler/simplCore/FloatOut.lhs | 14 +++++++++++--- 1 files changed, 11 insertions(+), 3 deletions(-) diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index 1b2555d..00d6554 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -567,9 +567,17 @@ wrapTick t (FB tops defns) where wrap_defns = mapBag wrap_one - wrap_bind (NonRec binder rhs) = NonRec binder (mkTick t rhs) - wrap_bind (Rec pairs) = Rec (mapSnd (mkTick t) pairs) + wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) + wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) - wrap_one (FloatCase e b c bs) = FloatCase (mkTick t e) b c bs + wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs + + maybe_tick e | exprIsHNF e = e + | otherwise = mkTick t e + -- we don't need to wrap a tick around an HNF when we float it + -- outside a tick: that is an invariant of the tick semantics + -- Conversely, inlining of HNFs inside an SCC is allowed, and + -- indeed the HNF we're floating here might well be inlined back + -- again, and we don't want to end up with duplicate ticks. \end{code} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
