X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=2f881d5a4a44f42b6f7ebb5cd573c54cd1abac00;hb=1cf3376346d32322f32acf65db9311b95842c308;hp=4ca68b26da71105a6cc62aa358acf57e34e3ece7;hpb=b6cc5851fa49720b31d989d210c8e43dc27cbfe6;p=ghc-hetmet.git diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 4ca68b2..2f881d5 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -370,7 +370,6 @@ completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside | otherwise = -- Make the arguments atomic if necessary, -- adding suitable bindings - -- pprTrace "completeNonRecX" (ppr new_bndr <+> ppr new_rhs) $ mkAtomicArgsE env is_strict new_rhs $ \ env new_rhs -> completeLazyBind env NotTopLevel old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) -> @@ -489,8 +488,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se else -- ANF-ise a constructor or PAP rhs - mkAtomicArgs False {- Not strict -} - ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) -> + mkAtomicArgs ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) -> -- If the result is a PAP, float the floats out, else wrap them -- By this time it's already been ANF-ised (if necessary) @@ -619,7 +617,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs -- and now x is not demanded (I'm assuming h is lazy) -- This really happens. Similarly -- let f = \x -> e in ...f..f... - -- After inling f at some of its call sites the original binding may + -- After inlining f at some of its call sites the original binding may -- (for example) be no longer strictly demanded. -- The solution here is a bit ad hoc... info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding @@ -1016,7 +1014,7 @@ completeCall env var cont (if dopt Opt_D_dump_inlinings dflags then pprTrace "Inlining done" (vcat [ text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "Inlined fn: " <+> ppr unfolding, + text "Inlined fn: " $$ nest 2 (ppr unfolding), text "Cont: " <+> ppr call_cont]) else id) $ @@ -1154,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) @@ -1167,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 (substExpr env (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 @@ -1192,7 +1220,18 @@ mkAtomicArgsE env is_strict rhs thing_inside | otherwise = 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 } + go env (App fun (substExpr env (Var arg_id))) args } + -- Note [Take care]: + -- If completeNonRecX was to do a postInlineUnconditionally + -- (undoing the effect of introducing the let-binding), we'd find arg_id had + -- no binding; hence the substExpr. This happens if we see + -- C (D x `cast` g) + -- Then we start by making a variable a1, thus + -- let a1 = D x `cast` g in C a1 + -- But then we deal with the rhs of a1, getting + -- let a2 = D x, a1 = a1 `cast` g in C a1 + -- And now the preInlineUnconditionally kicks in, and we substitute for a1 + where arg_ty = exprType arg no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg) @@ -1200,14 +1239,20 @@ mkAtomicArgsE env is_strict rhs thing_inside -- Old code: consider rewriting to be more like mkAtomicArgsE -mkAtomicArgs :: Bool -- A strict binding - -> Bool -- OK to float unlifted args +mkAtomicArgs :: Bool -- OK to float unlifted args -> OutExpr -> SimplM (OrdList (OutId,OutExpr), -- The floats (unusually) may include OutExpr) -- things that need case-binding, -- if the strict-binding flag is on -mkAtomicArgs is_strict ok_float_unlifted rhs +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 = go fun nilOL [] args -- Have a go @@ -1229,14 +1274,13 @@ mkAtomicArgs is_strict ok_float_unlifted rhs | otherwise -- Don't forget to do it recursively -- E.g. x = a:b:c:[] - = mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> - newId FSLIT("a") arg_ty `thenSmpl` \ arg_id -> + = mkAtomicArgs ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> + newId FSLIT("a") arg_ty `thenSmpl` \ arg_id -> go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) (Var arg_id : rev_args) args where arg_ty = exprType arg - can_float_arg = is_strict - || not (isUnLiftedType arg_ty) + can_float_arg = not (isUnLiftedType arg_ty) || (ok_float_unlifted && exprOkForSpeculation arg)