X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=d932ab1fdbad0b310ca0d1816990220116d3e09d;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hp=6eeb43d365d3d197b4ed900a9bf76db1b7f1fd6f;hpb=5e2dc400691d3ce0fb59daa8783cea06faba9c97;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 6eeb43d..d932ab1 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -8,7 +8,6 @@ Utilities for desugaring This module exports some utility functions of no great interest. \begin{code} - -- | Utility functions for constructing Core syntax, principally for desugaring module DsUtils ( EquationInfo(..), @@ -23,7 +22,7 @@ module DsUtils ( mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, wrapBind, wrapBinds, - mkErrorAppDs, + mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, seqVar, @@ -73,8 +72,6 @@ import Util import ListSetOps import FastString import StaticFlags - -import Data.Char \end{code} @@ -238,7 +235,7 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) -- let var' = viewExpr var in mr mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult mkViewMatchResult var' viewExpr var = - adjustMatchResult (mkCoreLet (NonRec var' (mkCoreApp viewExpr (Var var)))) + adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var)))) mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult mkEvalMatchResult var ty @@ -392,18 +389,97 @@ mkCoAlgCaseMatchResult var ty match_alts \begin{code} mkErrorAppDs :: Id -- The error function -> Type -- Type to which it should be applied - -> String -- The error message string to pass + -> SDoc -- The error message string to pass -> DsM CoreExpr mkErrorAppDs err_id ty msg = do src_loc <- getSrcSpanDs let - full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) + full_msg = showSDoc (hcat [ppr src_loc, text "|", msg]) core_msg = Lit (mkMachString full_msg) -- mkMachString returns a result of type String# return (mkApps (Var err_id) [Type ty, core_msg]) \end{code} +'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. + +Note [Desugaring seq (1)] cf Trac #1031 +~~~~~~~~~~~~~~~~~~~~~~~~~ + f x y = x `seq` (y `seq` (# x,y #)) + +The [CoreSyn let/app invariant] means that, other things being equal, because +the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + +But that is bad for two reasons: + (a) we now evaluate y before x, and + (b) we can't bind v to an unboxed pair + +Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + +Note [Desugaring seq (2)] cf Trac #2231 +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let chp = case b of { True -> fst x; False -> 0 } + in chp `seq` ...chp... +Here the seq is designed to plug the space leak of retaining (snd x) +for too long. + +If we rely on the ordinary inlining of seq, we'll get + let chp = case b of { True -> fst x; False -> 0 } + case chp of _ { I# -> ...chp... } + +But since chp is cheap, and the case is an alluring contet, we'll +inline chp into the case scrutinee. Now there is only one use of chp, +so we'll inline a second copy. Alas, we've now ruined the purpose of +the seq, by re-introducing the space leak: + case (case b of {True -> fst x; False -> 0}) of + I# _ -> ...case b of {True -> fst x; False -> 0}... + +We can try to avoid doing this by ensuring that the binder-swap in the +case happens, so we get his at an early stage: + case chp of chp2 { I# -> ...chp2... } +But this is fragile. The real culprit is the source program. Perhaps we +should have said explicitly + let !chp2 = chp in ...chp2... + +But that's painful. So the code here does a little hack to make seq +more robust: a saturated application of 'seq' is turned *directly* into +the case expression. So we desugar to: + let chp = case b of { True -> fst x; False -> 0 } + case chp of chp { I# -> ...chp... } +Notice the shadowing of the case binder! And now all is well. + +The reason it's a hack is because if you define mySeq=seq, the hack +won't work on mySeq. + +Note [Desugaring seq (3)] cf Trac #2409 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The isLocalId ensures that we don't turn + True `seq` e +into + case True of True { ... } +which stupidly tries to bind the datacon 'True'. + +\begin{code} +mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr +mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 + | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] + = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] + where + case_bndr = case arg1 of + Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] + _ -> mkWildBinder ty1 + +mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore + +mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreAppsDs fun args = foldl mkCoreAppDs fun args +\end{code} + + %************************************************************************ %* * \subsection[mkSelectorBind]{Make a selector bind} @@ -458,7 +534,7 @@ mkSelectorBinds pat val_expr -- For the error message we make one error-app, to avoid duplication. -- But we need it at different types... so we use coerce for that - err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat)) + err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat) err_var <- newSysLocalDs unitTy binds <- mapM (mk_bind val_var err_var) binders return ( (val_var, val_expr) : @@ -467,7 +543,7 @@ mkSelectorBinds pat val_expr | otherwise = do - error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) + error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat) tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr tuple_var <- newSysLocalDs tuple_ty let