Transformations.hs

module UHC.Light.Compiler.EHC.CompilePhase.Transformations
( cpTransformCore )
where
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Monad.State
import UHC.Util.Lens
import UHC.Light.Compiler.EHC.Common
import UHC.Light.Compiler.Base.Optimize
import UHC.Light.Compiler.EHC.CompileUnit
import UHC.Light.Compiler.EHC.CompileRun
import qualified UHC.Light.Compiler.Config as Cfg
import UHC.Light.Compiler.EHC.ASTHandler.Instances
import UHC.Light.Compiler.CodeGen.TrfUtils
import UHC.Light.Compiler.Core.Trf
import UHC.Light.Compiler.EHC.CompilePhase.Output
import qualified UHC.Light.Compiler.EH.Main as EHSem
import qualified UHC.Light.Compiler.Core.ToGrin as Core2GrSem
import qualified UHC.Light.Compiler.HI as HI
import qualified UHC.Light.Compiler.Core.Check as Core2ChkSem
import UHC.Light.Compiler.EHC.CompilePhase.Module(cpUpdHiddenExports)










{-# LINE 78 "src/ehc/EHC/CompilePhase/Transformations.chs" #-}
cpTransformCore :: EHCCompileRunner m => OptimizationScope -> HsName -> EHCompilePhaseT m ()
cpTransformCore optimScope modNm
  = do { cr <- get
       ; let  (ecu,crsi,opts,fp) = crBaseInfo modNm cr
       ; cpMsg' modNm VerboseALot "Transforming Core ..." Nothing fp

         -- transform
       ; let  mbCore     = _ecuMbCore ecu
              trfcoreIn  = emptyTrfCore
                             { trfstMod             	= panicJust "cpTransformCore" mbCore
                             , trfstUniq            	= crsi ^. crsiNextUID
                             , trfstExtra = emptyTrfCoreExtra
                                 { trfcoreECUState		= ecuState ecu
                                 -- , trfcoreIsLamLifted	= maybe False Core2ChkSem.isLamLifted_Syn_CodeAGItf $ _ecuMbCoreSemMod ecu
                                 , trfcoreNotYetTransformed
                                 						= maybe (trfcoreNotYetTransformed emptyTrfCoreExtra) Core2ChkSem.notYetTransformed_Syn_CodeAGItf $ _ecuMbCoreSemMod ecu
                                 , trfcoreExpNmOffMp    = crsiExpNmOffMpDbg "cpTransformCore" modNm crsi
								 , trfcoreInhLamMp      = crsi ^. crsiCEnv ^. cenvLamMp
                                 }
                             }
              trfcoreOut = trfCore opts optimScope
                                   (crsi ^. crsiCEnv ^. cenvDataGam)
                                   modNm trfcoreIn

       -- ; liftIO $ putStrLn $ "cpTransformCore trfcoreNotYetTransformed: " ++ show (trfcoreNotYetTransformed $ trfstExtra trfcoreIn)
       -- ; cpUpdSI $ (crsiCEnv ^* cenvLamMp) ^= (trfcoreGathLamMp $ trfstExtra trfcoreOut)
       -- put back result: Core
       ; cpUpdCU modNm $! ecuStoreCore (trfstMod trfcoreOut)

         -- put back result: unique counter
       ; cpSetUID (trfstUniq trfcoreOut)

         -- put back result: call info map (lambda arity, ...)
       ; let hii   = ecu ^. ecuHIInfo
             lamMp = HI.hiiLamMp hii
       ; cpUpdCU modNm
           ( ecuStoreHIInfo
               (hii { HI.hiiLamMp = (trfcoreGathLamMp $ trfstExtra trfcoreOut) `Map.union` lamMp
                    })
           )
         -- put back result: additional hidden exports, it should be in a cpFlowXX variant
       ; cpUpdHiddenExports modNm $ zip (Set.toList $ trfcoreExtraExports $ trfstExtra trfcoreOut) (repeat IdOcc_Val)

         -- dump intermediate stages, print errors, if any
       ; let (nms,mcs,errs) = unzip3 $ trfstModStages trfcoreOut
             (fc,sf) | CoreOpt_DumpAST `elem` ehcOptCoreOpts opts = (ASTFileContent_ASTText, Cfg.suffixDotlessOutputTextualCoreAST)
                     | otherwise                                  = (ASTFileContent_Text, Cfg.suffixDotlessOutputTextualCore)
       -- ; cpOutputCoreModules CPOutputCoreHow_Text (\n nm -> "-" ++ show optimScope ++ "-" ++ show n ++ "-" ++ nm) Cfg.suffixDotlessOutputTextualCore modNm [ (n,nm) | (n, Just nm) <- zip nms mcs ]
       ; cpOutputSomeModules
           (Just $ opts {ehcOptCoreOpts= CoreOpt_Readable : ehcOptCoreOpts opts})
           astHandler'_Core fc
           (\n nm -> "-" ++ show optimScope ++ "-" ++ show n ++ "-" ++ nm)
           sf modNm
           [ (n,nm) | (n, Just nm) <- zip nms mcs ]
       ; cpSeq $ zipWith (\nm err -> cpSetLimitErrsWhen 5 ("Core errors: " ++ nm) err) nms errs
       }