[commit: ghc] wip/T12618: Revert "CorePrep: Stop creating weird bindings for data constructor workers" (c9a3415)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12618
Link       : http://ghc.haskell.org/trac/ghc/changeset/c9a3415460ab6361ecdaf396800a3a533d62587e/ghc

>---------------------------------------------------------------

commit c9a3415460ab6361ecdaf396800a3a533d62587e
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Oct 7 21:43:24 2016 -0400

    Revert "CorePrep: Stop creating weird bindings for data constructor workers"
    
    This reverts commit 36143d401423e7fc427cef6ed71cb9dae3c9d561.


>---------------------------------------------------------------

c9a3415460ab6361ecdaf396800a3a533d62587e
 compiler/coreSyn/CorePrep.hs | 55 +++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 52 insertions(+), 3 deletions(-)

diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index fdd6f1b..d321064 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -54,6 +54,8 @@ import Outputable
 import Platform
 import FastString
 import Config
+import Name             ( NamedThing(..), nameSrcSpan )
+import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
 import Data.Bits
 import MonadUtils       ( mapAccumLM )
 import Data.List        ( mapAccumL )
@@ -166,16 +168,21 @@ type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 
 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
             -> IO CoreProgram
-corePrepPgm hsc_env this_mod _mod_loc binds _data_tycons =
+corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
     withTiming (pure dflags)
                (text "CorePrep"<+>brackets (ppr this_mod))
                (const ()) $ do
     us <- mkSplitUniqSupply 's'
     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
 
-    let binds_out = initUs_ us $ do
+    let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
+            -- NB: we must feed mkImplicitBinds through corePrep too
+            -- so that they are suitably cloned and eta-expanded
+
+        binds_out = initUs_ us $ do
                       floats1 <- corePrepTopBinds initialCorePrepEnv binds
-                      return (deFloatTop floats1)
+                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
+                      return (deFloatTop (floats1 `appendFloats` floats2))
 
     endPassIO hsc_env alwaysQualify CorePrep binds_out []
     return binds_out
@@ -201,6 +208,27 @@ corePrepTopBinds initialCorePrepEnv binds
                                binds' <- go env' binds
                                return (bind' `appendFloats` binds')
 
+mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
+-- See Note [Data constructor workers]
+-- c.f. Note [Injecting implicit bindings] in TidyPgm
+mkDataConWorkers dflags mod_loc data_tycons
+  = [ NonRec id (tick_it (getName data_con) (Var id))
+                                -- The ice is thin here, but it works
+    | tycon <- data_tycons,     -- CorePrep will eta-expand it
+      data_con <- tyConDataCons tycon,
+      let id = dataConWorkId data_con
+    ]
+ where
+   -- If we want to generate debug info, we put a source note on the
+   -- worker. This is useful, especially for heap profiling.
+   tick_it name
+     | debugLevel dflags == 0                = id
+     | RealSrcSpan span <- nameSrcSpan name  = tick span
+     | Just file <- ml_hs_file mod_loc       = tick (span1 file)
+     | otherwise                             = tick (span1 "???")
+     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))
+           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
+
 {-
 Note [Floating out of top level bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -253,6 +281,24 @@ out CafInfo later, after CorePrep.  We'll do that in due course.
 Meanwhile this horrible hack works.
 
 
+Note [Data constructor workers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Create any necessary "implicit" bindings for data con workers.  We
+create the rather strange (non-recursive!) binding
+
+        $wC = \x y -> $wC x y
+
+i.e. a curried constructor that allocates.  This means that we can
+treat the worker for a constructor like any other function in the rest
+of the compiler.  The point here is that CoreToStg will generate a
+StgConApp for the RHS, rather than a call to the worker (which would
+give a loop).  As Lennart says: the ice is thin here, but it works.
+
+Hmm.  Should we create bindings for dictionary constructors?  They are
+always fully applied, and the bindings are just there to support
+partial applications. But it's easier to let them through.
+
+
 Note [Dead code in CorePrep]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Imagine that we got an input program like this (see Trac #4962):
@@ -1258,6 +1304,9 @@ allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
 -- We decided not to adopt this solution to keep the definition
 -- of 'exprIsTrivial' simple.
 --
+-- There is ONE caveat however: for top-level bindings we have
+-- to preserve the binding so that we float the (hacky) non-recursive
+-- binding for data constructors; see Note [Data constructor workers].
 --
 -- Note [CorePrep inlines trivial CoreExpr not Id]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~