<commit_before>{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module CLaSH.GHC.LoadModules
  ( loadModules
  )
where

-- External Modules
import qualified GHC.Paths

-- GHC API
-- import qualified CorePrep
import qualified CoreSyn
import           DynFlags (GeneralFlag(..))
import qualified DynFlags
import           CLaSH.GHC.Compat.DynFlags (dopt_unset,dopt_set)
import qualified GHC
import           CLaSH.GHC.Compat.GHC (defaultErrorHandler)
-- import qualified HscMain
import qualified HscTypes
import qualified HsImpExp
import qualified MonadUtils
import           CLaSH.GHC.Compat.Outputable (showPpr)
import qualified Panic
import qualified SrcLoc
import qualified TidyPgm
-- import qualified TyCon
import qualified TysPrim
import qualified TysWiredIn

-- Internal Modules
import           CLaSH.GHC.LoadInterfaceFiles
import           CLaSH.Util (traceIf,curLoc,mapAccumLM,(><))

loadModules ::
  String
  -> IO ( [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]   -- Binders
        , [(CoreSyn.CoreBndr,[CoreSyn.CoreExpr])]  -- Dictionary Functions
        , [(CoreSyn.CoreBndr,Int)]                 -- Class operations
        , [CoreSyn.CoreBndr]                       -- Unlocatable Expressions
        , [GHC.TyCon]                              -- Type Constructors
        )
loadModules modName = defaultErrorHandler $
  GHC.runGhc (Just GHC.Paths.libdir) $ do
    dflags <- GHC.getSessionDynFlags
    let dflags1 = foldl DynFlags.xopt_set
                    (dflags
                      { DynFlags.ctxtStkDepth = 1000
                      , DynFlags.optLevel = 2
                      } )
                    [DynFlags.Opt_TemplateHaskell,DynFlags.Opt_Arrows]
    let dflags2 = wantedOptimizationFlags dflags1
    _ <- GHC.setSessionDynFlags dflags2
    target <- GHC.guessTarget modName Nothing
    GHC.setTargets [target]
    ldRes <- GHC.load GHC.LoadAllTargets
    case ldRes of
      GHC.Succeeded -> do
        modGraph <- GHC.getModuleGraph
        let externalImports = concatMap ( map ( SrcLoc.unLoc
                                              . HsImpExp.ideclName
                                              . SrcLoc.unLoc
                                              )
                                        . GHC.ms_textual_imps
                                        ) modGraph

        externalTyCons <- fmap snd $
                            mapAccumLM getExternalTyCons [] externalImports

        let allExtTyCons = concat externalTyCons ++
                                  TysWiredIn.wiredInTyCons ++
                                  TysPrim.primTyCons

        let modGraph' = map disableOptimizationsFlags modGraph
        tidiedMods <- mapM (\m -> do { pMod  <- parseModule m
                                     ; tcMod <- GHC.typecheckModule pMod
                                     ; dsMod <- fmap GHC.coreModule $ GHC.desugarModule tcMod
                                     ; hsc_env <- GHC.getSession
                                     -- ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod
                                     ; (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env dsMod
                                     ; let tycons     = HscTypes.cg_tycons tidy_guts
                                     ; let pgm        = HscTypes.cg_binds tidy_guts
                                     -- ; let pgm = HscTypes.mg_binds dsMod
                                     -- ; let dataTyCons = filter TyCon.isDataTyCon tycons
                                     -- ; dflags'' <- GHC.getSessionDynFlags
                                     -- ; prepBinders <- MonadUtils.liftIO $ CorePrep.corePrepPgm dflags'' hsc_env pgm dataTyCons
                                     ; return (CoreSyn.flattenBinds pgm,tycons)
                                     }
                             ) modGraph'

        let (binders,tyCons) = (concat >< concat) (unzip tidiedMods)

        (externalBndrs,dfuns,clsOps,unlocatable) <- loadExternalExprs
                                                (map snd binders)
                                                (map fst binders)

        traceIf (not $ null unlocatable) ("No exprs found for: " ++ showPpr unlocatable) $ return (binders ++ externalBndrs,dfuns,clsOps,unlocatable,tyCons ++ allExtTyCons)
      GHC.Failed -> Panic.pgmError $ $(curLoc) ++ "failed to load module: " ++ modName

parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule
parseModule modSum = do
  (GHC.ParsedModule pmModSum pmParsedSource extraSrc) <-
    GHC.parseModule modSum
  return (GHC.ParsedModule
            (disableOptimizationsFlags pmModSum)
            pmParsedSource extraSrc)

disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary
disableOptimizationsFlags ms@(GHC.ModSummary {..})
  = ms {GHC.ms_hspp_opts = dflags}
  where
    dflags = wantedOptimizationFlags (ms_hspp_opts
              {DynFlags.optLevel = 2, DynFlags.ctxtStkDepth = 1000})

wantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags
wantedOptimizationFlags df = foldl dopt_unset (foldl dopt_set df wanted) unwanted
  where
    wanted = [ Opt_Strictness -- [Wanted?] don't care about strictness
             , Opt_CSE -- CSE
             , Opt_FullLaziness -- Floats let-bindings outside enclosing lambdas
             , Opt_Specialise -- Specialise on types, specialise type-class-overloaded function defined in this module for the types
             , Opt_DoLambdaEtaExpansion -- We need eta-expansion anyway, so the more GHC does, the better
             , Opt_CaseMerge -- We want fewer case-statements
             , Opt_DictsCheap -- Makes dictionaries seem cheap to optimizer: hopefully inline
             , Opt_IrrefutableTuples -- User might enable, doesn't affect normalization, don't disable
             , Opt_SimpleListLiterals -- Avoids 'build' rule
             , Opt_ExposeAllUnfoldings -- We need all the unfoldings we can get
             , Opt_ForceRecomp -- Force recompilation: never bad
             ]

    unwanted = [ Opt_FloatIn -- Moves let-bindings inwards: defeats the normal-form with a single top-level let-binding
               , Opt_StaticArgumentTransformation -- [Wanted?] Turn on the static argument transformation, which turns a recursive function into a non-recursive one with a local recursive loop.
               , Opt_LiberateCase -- Perform unrolling of recursive RHS: avoid
               , Opt_SpecConstr -- Creates local-functions: avoid
               , Opt_IgnoreAsserts -- We don't care about assertions
               , Opt_DoEtaReduction -- We want eta-expansion
               , Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid
               , Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid
               , Opt_EnableRewriteRules -- Intermediate data-structures take up no space
               , Opt_Vectorise -- Don't care
               , Opt_VectorisationAvoidance -- Don't care
               , Opt_RegsGraph -- Don't care
               , Opt_RegsGraph -- Don't care
               , Opt_PedanticBottoms -- Stops eta-expansion through case: avoid
               , Opt_LlvmTBAA -- Don't care
               , Opt_CmmSink -- Don't care
               , Opt_CmmElimCommonBlocks -- Don't care
               , Opt_OmitYields -- Don't care
               , Opt_IgnoreInterfacePragmas -- We need all the unfoldings we can get
               , Opt_OmitInterfacePragmas -- We need all the unfoldings we can get
               , Opt_SimplPreInlining -- Does inlining, which destroys function hierarchy: avoid
               ]<commit_msg>Don't make all tuple-patterns irrefutable<commit_after>{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module CLaSH.GHC.LoadModules
  ( loadModules
  )
where

-- External Modules
import qualified GHC.Paths

-- GHC API
-- import qualified CorePrep
import qualified CoreSyn
import           DynFlags (GeneralFlag(..))
import qualified DynFlags
import           CLaSH.GHC.Compat.DynFlags (dopt_unset,dopt_set)
import qualified GHC
import           CLaSH.GHC.Compat.GHC (defaultErrorHandler)
-- import qualified HscMain
import qualified HscTypes
import qualified HsImpExp
import qualified MonadUtils
import           CLaSH.GHC.Compat.Outputable (showPpr)
import qualified Panic
import qualified SrcLoc
import qualified TidyPgm
-- import qualified TyCon
import qualified TysPrim
import qualified TysWiredIn

-- Internal Modules
import           CLaSH.GHC.LoadInterfaceFiles
import           CLaSH.Util (traceIf,curLoc,mapAccumLM,(><))

loadModules ::
  String
  -> IO ( [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]   -- Binders
        , [(CoreSyn.CoreBndr,[CoreSyn.CoreExpr])]  -- Dictionary Functions
        , [(CoreSyn.CoreBndr,Int)]                 -- Class operations
        , [CoreSyn.CoreBndr]                       -- Unlocatable Expressions
        , [GHC.TyCon]                              -- Type Constructors
        )
loadModules modName = defaultErrorHandler $
  GHC.runGhc (Just GHC.Paths.libdir) $ do
    dflags <- GHC.getSessionDynFlags
    let dflags1 = foldl DynFlags.xopt_set
                    (dflags
                      { DynFlags.ctxtStkDepth = 1000
                      , DynFlags.optLevel = 2
                      } )
                    [DynFlags.Opt_TemplateHaskell,DynFlags.Opt_Arrows]
    let dflags2 = wantedOptimizationFlags dflags1
    _ <- GHC.setSessionDynFlags dflags2
    target <- GHC.guessTarget modName Nothing
    GHC.setTargets [target]
    ldRes <- GHC.load GHC.LoadAllTargets
    case ldRes of
      GHC.Succeeded -> do
        modGraph <- GHC.getModuleGraph
        let externalImports = concatMap ( map ( SrcLoc.unLoc
                                              . HsImpExp.ideclName
                                              . SrcLoc.unLoc
                                              )
                                        . GHC.ms_textual_imps
                                        ) modGraph

        externalTyCons <- fmap snd $
                            mapAccumLM getExternalTyCons [] externalImports

        let allExtTyCons = concat externalTyCons ++
                                  TysWiredIn.wiredInTyCons ++
                                  TysPrim.primTyCons

        let modGraph' = map disableOptimizationsFlags modGraph
        tidiedMods <- mapM (\m -> do { pMod  <- parseModule m
                                     ; tcMod <- GHC.typecheckModule pMod
                                     ; dsMod <- fmap GHC.coreModule $ GHC.desugarModule tcMod
                                     ; hsc_env <- GHC.getSession
                                     -- ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod
                                     ; (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env dsMod
                                     ; let tycons     = HscTypes.cg_tycons tidy_guts
                                     ; let pgm        = HscTypes.cg_binds tidy_guts
                                     -- ; let pgm = HscTypes.mg_binds dsMod
                                     -- ; let dataTyCons = filter TyCon.isDataTyCon tycons
                                     -- ; dflags'' <- GHC.getSessionDynFlags
                                     -- ; prepBinders <- MonadUtils.liftIO $ CorePrep.corePrepPgm dflags'' hsc_env pgm dataTyCons
                                     ; return (CoreSyn.flattenBinds pgm,tycons)
                                     }
                             ) modGraph'

        let (binders,tyCons) = (concat >< concat) (unzip tidiedMods)

        (externalBndrs,dfuns,clsOps,unlocatable) <- loadExternalExprs
                                                (map snd binders)
                                                (map fst binders)

        traceIf (not $ null unlocatable) ("No exprs found for: " ++ showPpr unlocatable) $ return (binders ++ externalBndrs,dfuns,clsOps,unlocatable,tyCons ++ allExtTyCons)
      GHC.Failed -> Panic.pgmError $ $(curLoc) ++ "failed to load module: " ++ modName

parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule
parseModule modSum = do
  (GHC.ParsedModule pmModSum pmParsedSource extraSrc) <-
    GHC.parseModule modSum
  return (GHC.ParsedModule
            (disableOptimizationsFlags pmModSum)
            pmParsedSource extraSrc)

disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary
disableOptimizationsFlags ms@(GHC.ModSummary {..})
  = ms {GHC.ms_hspp_opts = dflags}
  where
    dflags = wantedOptimizationFlags (ms_hspp_opts
              {DynFlags.optLevel = 2, DynFlags.ctxtStkDepth = 1000})

wantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags
wantedOptimizationFlags df = foldl dopt_unset (foldl dopt_set df wanted) unwanted
  where
    wanted = [ Opt_Strictness -- [Wanted?] don't care about strictness
             , Opt_CSE -- CSE
             , Opt_FullLaziness -- Floats let-bindings outside enclosing lambdas
             , Opt_Specialise -- Specialise on types, specialise type-class-overloaded function defined in this module for the types
             , Opt_DoLambdaEtaExpansion -- We need eta-expansion anyway, so the more GHC does, the better
             , Opt_CaseMerge -- We want fewer case-statements
             , Opt_DictsCheap -- Makes dictionaries seem cheap to optimizer: hopefully inline
             , Opt_SimpleListLiterals -- Avoids 'build' rule
             , Opt_ExposeAllUnfoldings -- We need all the unfoldings we can get
             , Opt_ForceRecomp -- Force recompilation: never bad
             ]

    unwanted = [ Opt_FloatIn -- Moves let-bindings inwards: defeats the normal-form with a single top-level let-binding
               , Opt_StaticArgumentTransformation -- [Wanted?] Turn on the static argument transformation, which turns a recursive function into a non-recursive one with a local recursive loop.
               , Opt_LiberateCase -- Perform unrolling of recursive RHS: avoid
               , Opt_SpecConstr -- Creates local-functions: avoid
               , Opt_IgnoreAsserts -- We don't care about assertions
               , Opt_DoEtaReduction -- We want eta-expansion
               , Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid
               , Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid
               , Opt_EnableRewriteRules -- Intermediate data-structures take up no space
               , Opt_Vectorise -- Don't care
               , Opt_VectorisationAvoidance -- Don't care
               , Opt_RegsGraph -- Don't care
               , Opt_RegsGraph -- Don't care
               , Opt_PedanticBottoms -- Stops eta-expansion through case: avoid
               , Opt_LlvmTBAA -- Don't care
               , Opt_CmmSink -- Don't care
               , Opt_CmmElimCommonBlocks -- Don't care
               , Opt_OmitYields -- Don't care
               , Opt_IgnoreInterfacePragmas -- We need all the unfoldings we can get
               , Opt_OmitInterfacePragmas -- We need all the unfoldings we can get
               , Opt_SimplPreInlining -- Does inlining, which destroys function hierarchy: avoid
               , Opt_IrrefutableTuples -- Introduce irrefuntPatError: avoid
               ]
{'fraction_non_alphanumeric': 0.06990405326023105, 'fraction_numerical': 0.0018275569479798968, 'mean_word_length': 1.7277906355705892, 'pattern_counts': {'":': 0, '<': 41, '<?xml version=': 0, '>': 23, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 70, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5690640', 'n_tokens_mistral': 4362, 'n_tokens_neox': 4100, 'n_words': 1043}