{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wall #-}

-- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP
-- {-# OPTIONS_GHC -fno-warn-unused-binds   #-} -- TEMP

----------------------------------------------------------------------
-- |
-- Module      :  ConCat.Simplify
-- Copyright   :  (c) 2016 Conal Elliott
-- License     :  BSD3
--
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- 
----------------------------------------------------------------------

module ConCat.Simplify (simplifyE) where

-- TODO: explicit exports

import System.IO.Unsafe (unsafePerformIO)

#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
import GHC.Unit.External (eps_rule_base)  
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
#if !MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Core (emptyRuleEnv)
#endif
import GHC.Core.FamInstEnv (emptyFamInstEnvs)
import GHC.Core.Opt.OccurAnal (occurAnalyseExpr)
import GHC.Core.Opt.Simplify (simplExpr)
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Monad (SimplM,initSmpl)
import GHC.Core.Stats (exprSize)
import GHC.Plugins
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Core.Unfold (defaultUnfoldingOpts)
import qualified GHC.Utils.Logger as Err
#else
import qualified GHC.Utils.Error as Err
#endif
#else
import GhcPlugins
import Simplify (simplExpr)
import SimplMonad (SimplM,initSmpl)
import CoreSyn (emptyRuleEnv)
import qualified ErrUtils as Err
import SimplEnv
import CoreStats (exprSize)
import OccurAnal (occurAnalyseExpr)
import FamInstEnv (emptyFamInstEnvs)
#endif

#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
dumpIfSet_dyn' :: Err.Logger -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn' :: Logger -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn' Logger
logger DynFlags
_dflags DumpFlag
dumpFlag String
str =
  Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Err.putDumpFileMaybe Logger
logger DumpFlag
dumpFlag String
str DumpFormat
Err.FormatText
dumpIfSet' :: Err.Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet' :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet' Logger
logger DynFlags
_dflags Bool
_opt String
hdr SDoc
doc = Logger -> String -> SDoc -> IO ()
Err.logDumpMsg Logger
logger String
hdr SDoc
doc
#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
dumpIfSet_dyn' :: Err.Logger -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn' logger dflags dumpFlag str =
  Err.dumpIfSet_dyn logger dflags dumpFlag str Err.FormatCore
dumpIfSet' = Err.dumpIfSet
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
dumpIfSet_dyn' :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn' dflags dumpFlag str = Err.dumpIfSet_dyn dflags dumpFlag str Err.FormatCore
dumpIfSet' = Err.dumpIfSet
#else
dumpIfSet_dyn' :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn' = Err.dumpIfSet_dyn
dumpIfSet' = Err.dumpIfSet
#endif

{--------------------------------------------------------------------
    Simplification
--------------------------------------------------------------------}

-- We can't use simplifyExpr from SimplCore, because it doesn't inline.

-- TODO: I don't think I'm using inline with simplifyE, so switch to simplifyExpr.

simplifyE :: HscEnv -> DynFlags -> InScopeSet -> Bool -> CoreExpr -> CoreExpr
simplifyE :: HscEnv -> DynFlags -> InScopeSet -> Bool -> CoreExpr -> CoreExpr
simplifyE HscEnv
hsc_env DynFlags
dflags InScopeSet
inScopeSet Bool
inline = IO CoreExpr -> CoreExpr
forall a. IO a -> a
unsafePerformIO (IO CoreExpr -> CoreExpr)
-> (CoreExpr -> IO CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> DynFlags -> InScopeSet -> Bool -> CoreExpr -> IO CoreExpr
simplifyExpr HscEnv
hsc_env DynFlags
dflags InScopeSet
inScopeSet Bool
inline

simplifyExpr :: HscEnv
             -> DynFlags -- includes spec of what core-to-core passes to do
             -> InScopeSet
             -> Bool
             -> CoreExpr
             -> IO CoreExpr
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
--
-- Also used by Template Haskell
simplifyExpr :: HscEnv -> DynFlags -> InScopeSet -> Bool -> CoreExpr -> IO CoreExpr
simplifyExpr HscEnv
hsc_env DynFlags
dflags InScopeSet
inScopeSet Bool
inline CoreExpr
expr
  = do let sz :: Int
sz = CoreExpr -> Int
exprSize CoreExpr
expr
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
       Logger
logger <- IO Logger
Err.initLogger
       (CoreExpr
expr', SimplCount
counts) <- Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (FamInstEnv, FamInstEnv)
-> Int
-> SimplM CoreExpr
-> IO (CoreExpr, SimplCount)
forall a.
Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (FamInstEnv, FamInstEnv)
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger DynFlags
dflags
                            (ExternalPackageState -> RuleBase
eps_rule_base (ExternalPackageState -> RuleBase)
-> IO ExternalPackageState -> IO RuleBase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env)
                            RuleEnv
emptyRuleEnv
                            (FamInstEnv, FamInstEnv)
emptyFamInstEnvs Int
sz
                            (SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExprGently (DynFlags -> InScopeSet -> Bool -> Logger -> SimplEnv
simplEnvForCcc DynFlags
dflags InScopeSet
inScopeSet Bool
inline Logger
logger) CoreExpr
expr)
       Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet' Logger
logger DynFlags
dflags (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_simpl_stats DynFlags
dflags)
                  String
"Simplifier statistics" (SimplCount -> SDoc
pprSimplCount SimplCount
counts)
       Logger -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn' Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_simpl String
"Simplified expression"
                      (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr')
#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
       logger <- Err.initLogger
       (expr', counts) <- initSmpl logger dflags emptyRuleEnv
                            emptyFamInstEnvs sz
                            (simplExprGently (simplEnvForCcc dflags inScopeSet inline logger) expr)
       dumpIfSet' logger dflags (dopt Opt_D_dump_simpl_stats dflags)
                  "Simplifier statistics" (pprSimplCount counts)
       dumpIfSet_dyn' logger dflags Opt_D_dump_simpl "Simplified expression"
                      (ppr expr')
#else
       us <- mkSplitUniqSupply 'r'
       (expr', counts) <- initSmpl dflags emptyRuleEnv
                            emptyFamInstEnvs us sz
                            (simplExprGently (simplEnvForCcc dflags inline) expr)
       Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
               "Simplifier statistics" (pprSimplCount counts)
       dumpIfSet_dyn' dflags Opt_D_dump_simpl "Simplified expression"
                      (ppr expr')
#endif
       CoreExpr -> IO CoreExpr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr'

-- Copied from SimplCore (not exported)
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExprGently SimplEnv
env CoreExpr
expr = do
    CoreExpr
expr1 <- SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr SimplEnv
env (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
expr)
    SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr SimplEnv
env (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
expr1)

-- Like simplEnvForGHCi but with inlining.
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
simplEnvForCcc :: DynFlags -> InScopeSet -> Bool -> Err.Logger -> SimplEnv
simplEnvForCcc :: DynFlags -> InScopeSet -> Bool -> Logger -> SimplEnv
simplEnvForCcc DynFlags
dflags InScopeSet
inScopeSet Bool
inline Logger
logger
  = SimplEnv -> InScopeSet -> SimplEnv
setInScopeSet SimplEnv
env0 InScopeSet
inScopeSet
  where
    env0 :: SimplEnv
env0 = SimplMode -> SimplEnv
mkSimplEnv (SimplMode -> SimplEnv) -> SimplMode -> SimplEnv
forall a b. (a -> b) -> a -> b
$ SimplMode { sm_names :: [String]
sm_names = [String
"Simplify for ccc"]
                                  , sm_phase :: CompilerPhase
sm_phase = Int -> CompilerPhase
Phase Int
0 -- Was InitialPhase
                                  , sm_rules :: Bool
sm_rules = Bool
rules_on
                                  , sm_inline :: Bool
sm_inline = Bool
inline -- was False
                                  , sm_eta_expand :: Bool
sm_eta_expand = Bool
eta_expand_on
                                  , sm_case_case :: Bool
sm_case_case = Bool
True
                                  , sm_uf_opts :: UnfoldingOpts
sm_uf_opts = UnfoldingOpts
defaultUnfoldingOpts
                                  , sm_pre_inline :: Bool
sm_pre_inline = Bool
inline
                                  , sm_logger :: Logger
sm_logger = Logger
logger
                                  , sm_dflags :: DynFlags
sm_dflags = DynFlags
dflags
#if MIN_VERSION_GLASGOW_HASKELL(9,2,2,0)
                                  , sm_cast_swizzle :: Bool
sm_cast_swizzle = Bool
True
#endif
                                  }
    rules_on :: Bool
rules_on      = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules   DynFlags
dflags
    eta_expand_on :: Bool
eta_expand_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion DynFlags
dflags
#else
simplEnvForCcc :: DynFlags -> Bool -> SimplEnv
simplEnvForCcc dflags inline
  = mkSimplEnv $ SimplMode { sm_names = ["Simplify for ccc"]
                           , sm_phase = Phase 0 -- Was InitialPhase
                           , sm_rules = rules_on
                           , sm_inline = inline -- was False
                           , sm_eta_expand = eta_expand_on
                           , sm_case_case = True
                           , sm_dflags = dflags
                           }
  where
    rules_on      = gopt Opt_EnableRewriteRules   dflags
    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
#endif