Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/be9e727c99b3d746c6db1c4c65f99de2e3bcd70d >--------------------------------------------------------------- commit be9e727c99b3d746c6db1c4c65f99de2e3bcd70d Author: Simon Marlow <[email protected]> Date: Wed Nov 2 08:39:51 2011 +0000 simplTick: push type-applications and casts inside ticks. >--------------------------------------------------------------- compiler/simplCore/Simplify.lhs | 20 +++++++++++++++----- 1 files changed, 15 insertions(+), 5 deletions(-) diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index d4108d2..853815c 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1038,19 +1038,21 @@ simplTick env tickish expr cont -- -- For breakpoints, we cannot do any floating of bindings around the - -- tick. So + -- tick, because breakpoints cannot be split into tick/scope pairs. | Breakpoint{} <- tickish - = do { (env', expr') <- simplExprF (zapFloats env) expr mkBoringStop + = do { let (inc,outc) = splitCont cont + ; (env', expr') <- simplExprF (zapFloats env) expr inc ; let tickish' = simplTickish env tickish - ; (env'', expr'') <- rebuild (zapFloats env') (wrapFloats env' expr') (TickIt tickish' cont) + ; (env'', expr'') <- rebuild (zapFloats env') (wrapFloats env' expr') (TickIt tickish' outc) ; return (env'', wrapFloats env expr'') } | otherwise - = do { (env', expr') <- simplExprF (zapFloats env) expr mkBoringStop + = do { let (inc,outc) = splitCont cont + ; (env', expr') <- simplExprF (zapFloats env) expr inc ; let tickish' = simplTickish env tickish ; let env'' = addFloats env (mapFloatRhss env' (mkTick (mkNoTick tickish'))) - ; rebuild env'' expr' (TickIt tickish' cont) + ; rebuild env'' expr' (TickIt tickish' outc) } where simplTickish env tickish @@ -1058,6 +1060,14 @@ simplTick env tickish expr cont = Breakpoint n (map (getDoneId . substId env) ids) | otherwise = tickish + -- push type application and coercion inside a tick + splitCont :: SimplCont -> (SimplCont, SimplCont) + splitCont (ApplyTo f (Type t) env c) = (ApplyTo f (Type t) env inc, outc) + where (inc,outc) = splitCont c + splitCont (CoerceIt co c) = (CoerceIt co inc, outc) + where (inc,outc) = splitCont c + splitCont other = (mkBoringStop, other) + getDoneId (DoneId id) = id getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst getDoneId other = pprPanic "getDoneId" (ppr other) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
