[commit: ghc] master: Fix the implementation of lazyId (4c3a0a4)
git at git.haskell.org
git at git.haskell.org
Wed Mar 9 13:14:11 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/4c3a0a4a7b999251cbbee00befbfe32b86e556e2/ghc
>---------------------------------------------------------------
commit 4c3a0a4a7b999251cbbee00befbfe32b86e556e2
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Mar 8 15:27:54 2016 +0000
Fix the implementation of lazyId
'lazy' was doing part of its job, but not all! In particular,
an application
f (lazy e)
where f is strict, was still being compiled using call-by-value in
CorePrep. This defeated the purpose of defining catch as
catch a b = catch# (lazy a) b
See Trac #11555, and Neil Mitchell's test case in comment:14
This patch makes 'lazy' behave properly. I updated Note [lazyId magic]
in MkId, but all the action is in CorePrep.
I can't say I really like this, but it does the job.
>---------------------------------------------------------------
4c3a0a4a7b999251cbbee00befbfe32b86e556e2
compiler/basicTypes/MkId.hs | 57 +++++++++++++++++++++++++++++++-------------
compiler/coreSyn/CorePrep.hs | 48 +++++++++++++++++++++----------------
2 files changed, 68 insertions(+), 37 deletions(-)
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 8ee5013..92d6b5e 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -1324,23 +1324,46 @@ may fire.
Note [lazyId magic]
~~~~~~~~~~~~~~~~~~~
- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
-
-Used to lazify pseq: pseq a b = a `seq` lazy b
-
-Also, no strictness: by being a built-in Id, all the info about lazyId comes from here,
-not from GHC.Base.hi. This is important, because the strictness
-analyser will spot it as strict!
-
-Also no unfolding in lazyId: it gets "inlined" by a HACK in CorePrep.
-It's very important to do this inlining *after* unfoldings are exposed
-in the interface file. Otherwise, the unfolding for (say) pseq in the
-interface file will not mention 'lazy', so if we inline 'pseq' we'll totally
-miss the very thing that 'lazy' was there for in the first place.
-See Trac #3259 for a real world example.
-
-lazyId is defined in GHC.Base, so we don't *have* to inline it. If it
-appears un-applied, we'll end up just calling it.
+lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
+
+'lazy' is used to make sure that a sub-expression, and its free variables,
+are truly used call-by-need, with no code motion. Key examples:
+
+* pseq: pseq a b = a `seq` lazy b
+ We want to make sure that the free vars of 'b' are not evaluated
+ before 'a', even though the expression is plainly strict in 'b'.
+
+* catch: catch a b = catch# (lazy a) b
+ Again, it's clear that 'a' will be evaluated strictly (and indeed
+ applied to a state token) but we want to make sure that any exceptions
+ arising from the evaluation of 'a' are caught by the catch (see
+ Trac #11555).
+
+Implementing 'lazy' is a bit tricky:
+
+* It must not have a strictness signature: by being a built-in Id,
+ all the info about lazyId comes from here, not from GHC.Base.hi.
+ This is important, because the strictness analyser will spot it as
+ strict!
+
+* It must not have an unfolding: it gets "inlined" by a HACK in
+ CorePrep. It's very important to do this inlining *after* unfoldings
+ are exposed in the interface file. Otherwise, the unfolding for
+ (say) pseq in the interface file will not mention 'lazy', so if we
+ inline 'pseq' we'll totally miss the very thing that 'lazy' was
+ there for in the first place. See Trac #3259 for a real world
+ example.
+
+* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must
+ avoid using call by value here:
+ case e of r -> catch# r b
+ Avoiding that is the whole point of 'lazy'. So in CorePrep (which
+ generate the 'case' expression for a call-by-value call) we must
+ spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let'
+ instead.
+
+* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it
+ appears un-applied, we'll end up just calling it.
Note [runRW magic]
~~~~~~~~~~~~~~~~~~
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 3f9f4c8..e6acc2b 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -657,14 +657,14 @@ rhsToBody expr = return (emptyFloats, expr)
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- May return a CpeRhs because of saturating primops
cpeApp env expr
- = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
+ = do { (app, head, _, floats, ss) <- collect_args expr 0
; MASSERT(null ss) -- make sure we used all the strictness info
-- Now deal with the function
; case head of
- Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
- ; return (floats, sat_app) }
- _other -> return (floats, app) }
+ Just (fn_id, depth) -> do { sat_app <- maybeSaturate fn_id app depth
+ ; return (floats, sat_app) }
+ _other -> return (floats, app) }
where
-- Deconstruct and rebuild the application, floating any non-atomic
@@ -675,13 +675,13 @@ cpeApp env expr
collect_args
:: CoreExpr
- -> Int -- Current app depth
- -> UniqSM (CpeApp, -- The rebuilt expression
- (CoreExpr,Int), -- The head of the application,
- -- and no. of args it was applied to
- Type, -- Type of the whole expr
- Floats, -- Any floats we pulled out
- [Demand]) -- Remaining argument demands
+ -> Int -- Current app depth
+ -> UniqSM (CpeApp, -- The rebuilt expression
+ Maybe (Id, Int), -- The head of the application,
+ -- and no. of args it was applied to
+ Type, -- Type of the whole expr
+ Floats, -- Any floats we pulled out
+ [Demand]) -- Remaining argument demands
collect_args (App fun arg@(Type arg_ty)) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
@@ -693,12 +693,13 @@ cpeApp env expr
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
- ; let
- (ss1, ss_rest) = case ss of
- (ss1:ss_rest) -> (ss1, ss_rest)
- [] -> (topDmd, [])
- (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
- splitFunTy_maybe fun_ty
+ ; let (ss1, ss_rest) -- See Note [lazyId magic] in MkId
+ = case (ss, isLazyExpr arg) of
+ (_ : ss_rest, True) -> (topDmd, ss_rest)
+ (ss1 : ss_rest, False) -> (ss1, ss_rest)
+ ([], _) -> (topDmd, [])
+ (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
+ splitFunTy_maybe fun_ty
; (fs, arg') <- cpeArg env ss1 arg arg_ty
; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
@@ -706,7 +707,7 @@ cpeApp env expr
collect_args (Var v) depth
= do { v1 <- fiddleCCall v
; let v2 = lookupCorePrepEnv env v1
- ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
+ ; return (Var v2, Just (v2, depth), idType v2, emptyFloats, stricts) }
where
stricts = case idStrictness v of
StrictSig (DmdType _ demands _)
@@ -732,14 +733,21 @@ cpeApp env expr
; return (fun',hd,fun_ty,addFloat floats (FloatTick tickish),ss) }
-- N-variable fun, better let-bind it
- collect_args fun depth
+ collect_args fun _
= do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
-- The evalDmd says that it's sure to be evaluated,
-- so we'll end up case-binding it
- ; return (fun', (fun', depth), ty, fun_floats, []) }
+ ; return (fun', Nothing, ty, fun_floats, []) }
where
ty = exprType fun
+isLazyExpr :: CoreExpr -> Bool
+-- See Note [lazyId magic] in MkId
+isLazyExpr (Cast e _) = isLazyExpr e
+isLazyExpr (Tick _ e) = isLazyExpr e
+isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
+isLazyExpr _ = False
+
-- ---------------------------------------------------------------------------
-- CpeArg: produces a result satisfying CpeArg
-- ---------------------------------------------------------------------------
More information about the ghc-commits
mailing list