Fix the implementation of lazyId
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 8 Mar 2016 15:27:54 +0000 (15:27 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 9 Mar 2016 13:16:13 +0000 (13:16 +0000)
'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.

compiler/basicTypes/MkId.hs
compiler/coreSyn/CorePrep.hs

index 8ee5013..92d6b5e 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~
index 3f9f4c8..e6acc2b 100644 (file)
@@ -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
 -- ---------------------------------------------------------------------------