Simplify: Make generated names more useful

makeTrivial is responsible for concocting names during simplification.
Previously, however, it would make no attempt to generate a name that
might be useful to later readers of the resulting Core. Here we add a
bit of state to SimplEnv: a finite depth stack of binders within which
we are currently simplifying. We then derive generated binders from this
context.

See #11676.

Open questions:
  * Is there a better way to accomplish this?
  * Is `maxContextDepth` too large/small?

Test Plan: Validate, look at Core.

Reviewers: austin, simonpj

Reviewed By: simonpj

Subscribers: thomie, simonpj

Differential Revision: https://phabricator.haskell.org/D1970

GHC Trac Issues: #11676

1 files changed, 19 insertions, 13 deletions

diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 0e5da9bc5a..e9053002d6 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -21,7 +21,7 @@ import Id
 import MkId             ( seqId, voidPrimId )
 import MkCore           ( mkImpossibleExpr, castBottomExpr )
 import IdInfo
-import Name             ( Name, mkSystemVarName, isExternalName )
+import Name             ( Name, mkSystemVarName, isExternalName, getOccFS )
 import Coercion hiding  ( substCo, substCoVar )
 import OptCoercion      ( optCoercion )
 import FamInstEnv       ( topNormaliseType_maybe )
@@ -458,14 +458,14 @@ prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv,
 prepareRhs top_lvl env id (Cast rhs co)    -- Note [Float coercions]
   | Pair ty1 _ty2 <- coercionKind co       -- Do *not* do this if rhs has an unlifted type
   , not (isUnliftedType ty1)            -- see Note [Float coercions (unlifted)]
-  = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
+  = do  { (env', rhs') <- makeTrivialWithInfo top_lvl env (getOccFS id) sanitised_info rhs
         ; return (env', Cast rhs' co) }
   where
     sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
                                    `setDemandInfo` demandInfo info
     info = idInfo id
 
-prepareRhs top_lvl env0 _ rhs0
+prepareRhs top_lvl env0 id rhs0
   = do  { (_is_exp, env1, rhs1) <- go 0 env0 rhs0
         ; return (env1, rhs1) }
   where
@@ -478,7 +478,7 @@ prepareRhs top_lvl env0 _ rhs0
     go n_val_args env (App fun arg)
         = do { (is_exp, env', fun') <- go (n_val_args+1) env fun
              ; case is_exp of
-                True -> do { (env'', arg') <- makeTrivial top_lvl env' arg
+                True -> do { (env'', arg') <- makeTrivial top_lvl env' (getOccFS id) arg
                            ; return (True, env'', App fun' arg') }
                 False -> return (False, env, App fun arg) }
     go n_val_args env (Var fun)
@@ -559,27 +559,33 @@ These strange casts can happen as a result of case-of-case
 -}
 
 makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)
-makeTrivialArg env (ValArg e) = do { (env', e') <- makeTrivial NotTopLevel env e
-                                   ; return (env', ValArg e') }
+makeTrivialArg env (ValArg e) = do
+    { (env', e') <- makeTrivial NotTopLevel env (fsLit "arg") e
+    ; return (env', ValArg e') }
 makeTrivialArg env arg        = return (env, arg)  -- CastBy, TyArg
 
-makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
+makeTrivial :: TopLevelFlag -> SimplEnv
+            -> FastString  -- ^ a "friendly name" to build the new binder from
+            -> OutExpr -> SimplM (SimplEnv, OutExpr)
 -- Binds the expression to a variable, if it's not trivial, returning the variable
-makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr
+makeTrivial top_lvl env context expr =
+    makeTrivialWithInfo top_lvl env context vanillaIdInfo expr
 
-makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -> IdInfo
-                    -> OutExpr -> SimplM (SimplEnv, OutExpr)
+makeTrivialWithInfo :: TopLevelFlag -> SimplEnv
+                    -> FastString
+                    -- ^ a "friendly name" to build the new binder from
+                    -> IdInfo -> OutExpr -> SimplM (SimplEnv, OutExpr)
 -- Propagate strictness and demand info to the new binder
 -- Note [Preserve strictness when floating coercions]
 -- Returned SimplEnv has same substitution as incoming one
-makeTrivialWithInfo top_lvl env info expr
+makeTrivialWithInfo top_lvl env context info expr
   | exprIsTrivial expr                          -- Already trivial
   || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
                                                 --   See Note [Cannot trivialise]
   = return (env, expr)
   | otherwise           -- See Note [Take care] below
   = do  { uniq <- getUniqueM
-        ; let name = mkSystemVarName uniq (fsLit "a")
+        ; let name = mkSystemVarName uniq context
               var = mkLocalIdOrCoVarWithInfo name expr_ty info
         ; env'  <- completeNonRecX top_lvl env False var var expr
         ; expr' <- simplVar env' var
@@ -2402,7 +2408,7 @@ mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se, sc_cont
         --              in [...hole...] a
     do  { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
         ; (_, se', arg') <- simplArg env' dup se arg
-        ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
+        ; (env'', arg'') <- makeTrivial NotTopLevel env' (fsLit "karg") arg'
         ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = se'
                                     , sc_dup = OkToDup, sc_cont = dup_cont }
         ; return (env'', app_cont, nodup_cont) }