Plug EtaWorkerWrapper transformation into the Core2Core pipeline. It is now

useable with the flag "-feta-arity".

8 files changed, 29 insertions, 4 deletions

diff --git a/compiler/coreSyn/CoreEta.hs b/compiler/coreSyn/CoreEta.hs
index 3d3f0c6041..446729aaaa 100644
--- a/compiler/coreSyn/CoreEta.hs
+++ b/compiler/coreSyn/CoreEta.hs
@@ -10,6 +10,7 @@ import GhcPrelude
 
 import BasicTypes
 import CoreSyn
+import CoreArity
 import FastString
 import Id
 import Name
@@ -40,7 +41,7 @@ arityWorkerWrapper (Rec binds)
 -- a wrapper.
 arityWorkerWrapper' :: CoreBndr -> CoreExpr -> [(CoreBndr,CoreExpr)]
 arityWorkerWrapper' name expr
-  = let arity  = idArity name in
+  = let arity = idArity name in
       case arity >= 1 of
         True -> [ mkArityWrapper name expr arity
                 , mkArityWorker  name expr arity ]
@@ -60,8 +61,6 @@ mkWorkerName bndr
                  (mkOccName OccName.varName
                             (occNameString (nameOccName (Var.varName bndr))
                              ++ "worker"))
-  -- let name = varName bndr in
-  --   setVarName bndr (mkSystemVarName undefined (mkFastString "worker"))
 
 -- ^ Given an expression and it's name, generate a new expression with a
 -- tilde-lambda type. For expressions that are not functions, we do not generate
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 848371d7ae..c3e3778f91 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -289,6 +289,7 @@ coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
 coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
 coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity
+coreDumpFlag CoreDoEtaArity           = Just Opt_D_dump_eta_arity
 coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify
 coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
 coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 7e9171adc9..635234f303 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -309,6 +309,7 @@ Library
         GHC.StgToCmm.ExtCode
         SMRep
         CoreArity
+        CoreEta
         CoreFVs
         CoreLint
         CorePrep
@@ -472,6 +473,7 @@ Library
         StgSyn
         StgFVs
         CallArity
+        EtaWorkerWrapper
         DmdAnal
         Exitify
         WorkWrap
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 70f50f2a8b..7d398e5ad8 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -458,6 +458,7 @@ data DumpFlag
    | Opt_D_dump_stg_unarised -- STG after unarise
    | Opt_D_dump_stg_final -- STG after stg2stg
    | Opt_D_dump_call_arity
+   | Opt_D_dump_eta_arity
    | Opt_D_dump_exitify
    | Opt_D_dump_stranal
    | Opt_D_dump_str_signatures
@@ -530,6 +531,7 @@ data GeneralFlag
 
    -- optimisation opts
    | Opt_CallArity
+   | Opt_EtaArity
    | Opt_Exitification
    | Opt_Strictness
    | Opt_LateDmdAnal                    -- #6087
@@ -744,6 +746,7 @@ data GeneralFlag
 optimisationFlags :: EnumSet GeneralFlag
 optimisationFlags = EnumSet.fromList
    [ Opt_CallArity
+   , Opt_EtaArity
    , Opt_Strictness
    , Opt_LateDmdAnal
    , Opt_KillAbsence
@@ -3403,6 +3406,8 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_stg_final)
   , make_ord_flag defGhcFlag "ddump-call-arity"
         (setDumpFlag Opt_D_dump_call_arity)
+  , make_ord_flag defGhcFlag "ddump-eta-arity"
+        (setDumpFlag Opt_D_dump_eta_arity)
   , make_ord_flag defGhcFlag "ddump-exitify"
         (setDumpFlag Opt_D_dump_exitify)
   , make_ord_flag defGhcFlag "ddump-stranal"
@@ -4186,6 +4191,7 @@ fFlagsDeps = [
   flagGhciSpec "break-on-exception"           Opt_BreakOnException,
   flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,
   flagSpec "call-arity"                       Opt_CallArity,
+  flagSpec "eta-arity"                        Opt_EtaArity,
   flagSpec "exitification"                    Opt_Exitification,
   flagSpec "case-merge"                       Opt_CaseMerge,
   flagSpec "case-folding"                     Opt_CaseFolding,
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index e8575d3a21..f0dbc6734b 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -26,7 +26,6 @@ import CoreUtils        (rhsIsStatic)
 import CoreStats        (coreBindsStats, CoreStats(..))
 import CoreSeq          (seqBinds)
 import CoreLint
-import CoreEta
 import Literal
 import Rules
 import PatSyn
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index d2918a263f..3fcebb43e9 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -103,6 +103,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoPrintCore
   | CoreDoStaticArgs
   | CoreDoCallArity
+  | CoreDoEtaArity
   | CoreDoExitify
   | CoreDoStrictness
   | CoreDoWorkerWrapper
@@ -130,6 +131,7 @@ instance Outputable CoreToDo where
   ppr CoreLiberateCase         = text "Liberate case"
   ppr CoreDoStaticArgs         = text "Static argument"
   ppr CoreDoCallArity          = text "Called arity analysis"
+  ppr CoreDoEtaArity           = text "Eta-Arity worker/wrapper tranformation"
   ppr CoreDoExitify            = text "Exitification transformation"
   ppr CoreDoStrictness         = text "Demand analysis"
   ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"
diff --git a/compiler/simplCore/EtaWorkerWrapper.hs b/compiler/simplCore/EtaWorkerWrapper.hs
new file mode 100644
index 0000000000..3d92087697
--- /dev/null
+++ b/compiler/simplCore/EtaWorkerWrapper.hs
@@ -0,0 +1,10 @@
+module EtaWorkerWrapper (etaArityWorkerWrapperProgram) where
+
+import GhcPrelude
+
+import CoreEta
+import CoreSyn
+import DynFlags ( DynFlags )
+
+etaArityWorkerWrapperProgram :: DynFlags -> CoreProgram -> CoreProgram
+etaArityWorkerWrapperProgram _dflags binds = concatMap arityWorkerWrapper binds
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index cbfa757552..69ccded58b 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -46,6 +46,7 @@ import Specialise       ( specProgram)
 import SpecConstr       ( specConstrProgram)
 import DmdAnal          ( dmdAnalProgram )
 import CallArity        ( callArityAnalProgram )
+import EtaWorkerWrapper ( etaArityWorkerWrapperProgram )
 import Exitify          ( exitifyProgram )
 import WorkWrap         ( wwTopBinds )
 import SrcLoc
@@ -121,6 +122,7 @@ getCoreToDo dflags
     max_iter      = maxSimplIterations dflags
     rule_check    = ruleCheck          dflags
     call_arity    = gopt Opt_CallArity                    dflags
+    eta_arity     = gopt Opt_EtaArity                     dflags
     exitification = gopt Opt_Exitification                dflags
     strictness    = gopt Opt_Strictness                   dflags
     full_laziness = gopt Opt_FullLaziness                 dflags
@@ -200,6 +202,7 @@ getCoreToDo dflags
         ]
 
     core_todo =
+     [runWhen eta_arity $ CoreDoPasses [ CoreDoCallArity, CoreDoEtaArity ]] ++
      if opt_level == 0 then
        [ static_ptrs_float_outwards,
          CoreDoSimplify max_iter
@@ -441,6 +444,9 @@ doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
 doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}
                                        doPassD callArityAnalProgram
 
+doCorePass CoreDoEtaArity            = {-# SCC "EtaArity" #-}
+                                       doPassD etaArityWorkerWrapperProgram
+
 doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}
                                        doPass exitifyProgram