module UHC.Light.Compiler.EHC.CompilePhase.FlowBetweenPhase ( cpFlowEHSem1 , cpFlowHsSem1 , cpFlowHISem , cpFlowCoreModSem , cpFlowCoreSemAfterFold, cpFlowCoreSemBeforeFold , cpFlowHILamMp , cpFlowOptim ) where import qualified Data.Map as Map import qualified Data.Set as Set import UHC.Util.Lens import Control.Monad.State import UHC.Light.Compiler.EHC.Common import UHC.Light.Compiler.EHC.CompileUnit import UHC.Light.Compiler.EHC.CompileRun import qualified UHC.Light.Compiler.EH.MainAG as EHSem import qualified UHC.Light.Compiler.HS.MainAG as HSSem import qualified UHC.Light.Compiler.Core.ToGrin as Core2GrSem import UHC.Light.Compiler.LamInfo import UHC.Light.Compiler.Module.ImportExport import UHC.Light.Compiler.EHC.CompilePhase.Module import UHC.Light.Compiler.Core import UHC.Light.Compiler.Core.UsedModNms import qualified UHC.Light.Compiler.Core.Check as Core2ChkSem import qualified UHC.Light.Compiler.HI as HI import UHC.Light.Compiler.CHR.Solve (chrStoreUnion) import UHC.Light.Compiler.Base.Debug import UHC.Util.Pretty import qualified UHC.Util.FastSeq as Seq import UHC.Light.Compiler.EHC.CompilePhase.Module(cpUpdHiddenExports) {-# LINE 78 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-} prepFlow :: a -> a prepFlow x | x `seq` True = x -- prepFlow = id gamUnionFlow :: Ord k => Gam k v -> Gam k v -> Gam k v gamUnionFlow = gamUnion {-# LINE 99 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-} cpFlowHsSem1 :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpFlowHsSem1 modNm = do { cr <- get ; let (ecu,crsi,opts,_) = crBaseInfo modNm cr hsSem = panicJust "cpFlowHsSem1" $ _ecuMbHSSem ecu ehInh = crsi ^. crsiEHInh hsInh = crsi ^. crsiHSInh hii = ecu ^. ecuHIInfo ig = prepFlow $! HSSem.gathIdGam_Syn_AGItf hsSem fg = prepFlow $! HSSem.gathFixityGam_Syn_AGItf hsSem hsInh' = hsInh { HSSem.idGam_Inh_AGItf = ig `gamUnionFlow` HSSem.idGam_Inh_AGItf hsInh , HSSem.fixityGam_Inh_AGItf = fg `gamUnionFlow` HSSem.fixityGam_Inh_AGItf hsInh } ehInh' = ehInh { EHSem.idQualGam_Inh_AGItf = idGam2QualGam ig `gamUnionFlow` EHSem.idQualGam_Inh_AGItf ehInh } hii' = hii { HI.hiiFixityGam = fg -- , HI.hiiIdDefHIIdGam = HI.hiiIdDefOccGamToHIIdGam ig , HI.hiiHIDeclImpModS = ecuHIDeclImpNmS ecu } opts' = opts { ehcOptBuiltinNames = mkEHBuiltinNames mk } where mk = if ehcOptUseAssumePrelude opts then \_ n -> n else \k n -> idQualGamReplacement (EHSem.idQualGam_Inh_AGItf ehInh') k (hsnQualified n) ; when (isJust (_ecuMbHSSem ecu)) (do { cpUpdSI (\crsi -> crsi {_crsiHSInh = hsInh', _crsiEHInh = ehInh', _crsiOpts = opts'}) ; cpUpdCU modNm $! ecuStoreHIInfo hii' -- ; liftIO $ putStrLn (forceEval hii' `seq` "cpFlowHsSem1") }) -- ; liftIO $ putWidthPPLn 120 (ppGam $ EHSem.idQualGam_Inh_AGItf $ ehInh') } {-# LINE 142 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-} cpFlowEHSem1 :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpFlowEHSem1 modNm = do { cr <- get ; let (ecu,crsi,opts,_) = crBaseInfo modNm cr ehSem = panicJust "cpFlowEHSem1.ehSem" $ _ecuMbEHSem ecu ehInh = crsi ^. crsiEHInh coreInh = crsiCoreInh crsi dg = prepFlow $! EHSem.gathDataGam_Syn_AGItf ehSem vg = prepFlow $! EHSem.gathValGam_Syn_AGItf ehSem tg = prepFlow $! EHSem.gathTyGam_Syn_AGItf ehSem tkg = prepFlow $! EHSem.gathTyKiGam_Syn_AGItf ehSem pg = prepFlow $! EHSem.gathPolGam_Syn_AGItf ehSem kg = prepFlow $! EHSem.gathKiGam_Syn_AGItf ehSem clg = prepFlow $! EHSem.gathClGam_Syn_AGItf ehSem dfg = prepFlow $! EHSem.gathClDfGam_Syn_AGItf ehSem cs = prepFlow $! EHSem.gathChrStore_Syn_AGItf ehSem lm = prepFlow $! EHSem.gathLamMp_Syn_AGItf ehSem mmi = panicJust "cpFlowEHSem1.crsiModMp" $ Map.lookup modNm $ crsiModMp crsi hii = ecu ^. ecuHIInfo mentrelFilterMp = mentrelFilterMpUnions [ EHSem.gathMentrelFilterMp_Syn_AGItf ehSem, mentrelToFilterMp' False [modNm] (mmiExps mmi) ] usedImpS = mentrelFilterMpModuleNames mentrelFilterMp ehInh' = ehInh { EHSem.dataGam_Inh_AGItf = dg `gamUnionFlow` EHSem.dataGam_Inh_AGItf ehInh , EHSem.valGam_Inh_AGItf = vg `gamUnionFlow` EHSem.valGam_Inh_AGItf ehInh , EHSem.tyGam_Inh_AGItf = tg `gamUnionFlow` EHSem.tyGam_Inh_AGItf ehInh , EHSem.tyKiGam_Inh_AGItf = tkg `gamUnionFlow` EHSem.tyKiGam_Inh_AGItf ehInh , EHSem.polGam_Inh_AGItf = pg `gamUnionFlow` EHSem.polGam_Inh_AGItf ehInh , EHSem.kiGam_Inh_AGItf = kg `gamUnionFlow` EHSem.kiGam_Inh_AGItf ehInh , EHSem.clGam_Inh_AGItf = clg `gamUnionFlow` EHSem.clGam_Inh_AGItf ehInh , EHSem.clDfGam_Inh_AGItf = dfg `gamUnionFlow` EHSem.clDfGam_Inh_AGItf ehInh , EHSem.chrStore_Inh_AGItf = cs `chrStoreUnion` EHSem.chrStore_Inh_AGItf ehInh } hii' = hii { -- 20100717 AD: redundant because later extracted from Core because of inlining etc, TBD HI.hiiHIUsedImpModS = usedImpS , HI.hiiMbOrphan = EHSem.mbOrphan_Syn_AGItf ehSem , HI.hiiValGam = vg , HI.hiiTyGam = tg , HI.hiiTyKiGam = tkg , HI.hiiPolGam = pg , HI.hiiDataGam = dg , HI.hiiClGam = clg , HI.hiiClDfGam = dfg , HI.hiiCHRStore = {- HI.hiiScopedPredStoreToList -} cs -- , HI.hiiLamMp = lm } coreInh' = coreInh { Core2GrSem.dataGam_Inh_CodeAGItf = EHSem.dataGam_Inh_AGItf ehInh' , Core2GrSem.lamMp_Inh_CodeAGItf = lm `lamMpUnionBindAspMp` Core2GrSem.lamMp_Inh_CodeAGItf coreInh -- assumption: no duplicates, otherwise merging as done later has to be done } ; when (isJust (_ecuMbEHSem ecu)) (do { cpUpdSI (\crsi -> crsi { crsiCoreInh = coreInh', _crsiEHInh = ehInh' } ) ; cpUpdCU modNm ( ecuStoreHIInfo hii' . ecuStoreHIUsedImpS usedImpS . ecuStoreUsedNames mentrelFilterMp ) -- put back additional hidden exports ; cpUpdHiddenExports modNm $ Seq.toList $ EHSem.gathHiddenExports_Syn_AGItf ehSem }) } {-# LINE 246 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-} cpFlowHISem :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpFlowHISem modNm = do { cr <- get ; let (ecu,crsi,_,_) = crBaseInfo modNm cr -- hiSem = panicJust "cpFlowHISem.hiSem" $ ecuMbPrevHISem ecu hiInfo = panicJust "cpFlowHISem.hiInfo" $ _ecuMbPrevHIInfo ecu ehInh = crsi ^. crsiEHInh ehInh' = ehInh { EHSem.valGam_Inh_AGItf = (HI.hiiValGam hiInfo) `gamUnionFlow` EHSem.valGam_Inh_AGItf ehInh , EHSem.tyGam_Inh_AGItf = (HI.hiiTyGam hiInfo) `gamUnionFlow` EHSem.tyGam_Inh_AGItf ehInh , EHSem.tyKiGam_Inh_AGItf = (HI.hiiTyKiGam hiInfo) `gamUnionFlow` EHSem.tyKiGam_Inh_AGItf ehInh , EHSem.polGam_Inh_AGItf = (HI.hiiPolGam hiInfo) `gamUnionFlow` EHSem.polGam_Inh_AGItf ehInh , EHSem.dataGam_Inh_AGItf = (HI.hiiDataGam hiInfo) `gamUnionFlow` EHSem.dataGam_Inh_AGItf ehInh , EHSem.clGam_Inh_AGItf = (HI.hiiClGam hiInfo) `gamUnionFlow` EHSem.clGam_Inh_AGItf ehInh , EHSem.clDfGam_Inh_AGItf = (HI.hiiClDfGam hiInfo) `gamUnionFlow` EHSem.clDfGam_Inh_AGItf ehInh , EHSem.chrStore_Inh_AGItf = (HI.hiiCHRStore hiInfo) `chrStoreUnion` EHSem.chrStore_Inh_AGItf ehInh } hsInh = crsi ^. crsiHSInh hsInh' = hsInh { HSSem.fixityGam_Inh_AGItf = (HI.hiiFixityGam hiInfo) `gamUnionFlow` HSSem.fixityGam_Inh_AGItf hsInh , HSSem.idGam_Inh_AGItf = (HI.hiiIdDefOccGam hiInfo) `gamUnionFlow` HSSem.idGam_Inh_AGItf hsInh } coreInh = crsiCoreInh crsi coreInh' = coreInh { Core2GrSem.lamMp_Inh_CodeAGItf = (HI.hiiLamMp hiInfo) `lamMpUnionBindAspMp` Core2GrSem.lamMp_Inh_CodeAGItf coreInh } optim = crsiOptim crsi optim' = optim ; when (isJust (_ecuMbPrevHIInfo ecu)) (do { cpUpdSI (\crsi -> crsi { _crsiEHInh = ehInh' , _crsiHSInh = {- tr "cpFlowHISem.crsiHSInh" (pp $ HSSem.idGam_Inh_AGItf hsInh') $ -} hsInh' , crsiCoreInh = coreInh' , crsiOptim = optim' }) }) } {-# LINE 297 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-} -- | Flow info after Core source check cpFlowCoreModSem :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpFlowCoreModSem modNm = do { cr <- get ; let (ecu,crsi,opts,_) = crBaseInfo modNm cr coreInh = crsiCoreInh crsi mbCoreModSem = _ecuMbCoreSemMod ecu ; when (isJust mbCoreModSem) $ do { let coreModSem = fromJust mbCoreModSem coreInh' = coreInh { Core2GrSem.dataGam_Inh_CodeAGItf = Core2GrSem.dataGam_Inh_CodeAGItf coreInh `gamUnionFlow` Core2ChkSem.gathDataGam_Syn_CodeAGItf coreModSem } ; cpUpdSI (\crsi -> crsi { crsiCoreInh = coreInh' }) } } {-# LINE 317 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-} cpFlowCoreSemAfterFold :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpFlowCoreSemAfterFold modNm = do { cr <- get ; let (ecu,crsi,opts,_) = crBaseInfo modNm cr coreSem = panicJust "cpFlowCoreSemAfterFold.coreSem" $ _ecuMbCoreSem ecu coreInh = crsiCoreInh crsi hii = ecu ^. ecuHIInfo am = prepFlow $! Core2GrSem.gathLamMp_Syn_CodeAGItf coreSem coreInh' = coreInh { Core2GrSem.lamMp_Inh_CodeAGItf = am `lamMpUnionBindAspMp` Core2GrSem.lamMp_Inh_CodeAGItf coreInh -- assumption: old info can be overridden, otherwise merge should be done here } hii' = hii { HI.hiiLamMp = am } ; when (isJust (_ecuMbCoreSem ecu)) (do { cpUpdSI (\crsi -> crsi {crsiCoreInh = coreInh'}) ; cpUpdCU modNm ( ecuStoreHIInfo hii' ) }) } cpFlowCoreSemBeforeFold :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpFlowCoreSemBeforeFold modNm = do { cr <- get ; let (ecu,crsi,opts,_) = crBaseInfo modNm cr core = panicJust "cpFlowCoreSemBeforeFold.core" $ _ecuMbCore ecu -- 20100717 AD: required here because of inlining etc, TBD (usedImpS, introdModS) = cmodUsedModNms core hii = ecu ^. ecuHIInfo hii' = hii { -- 20100717 AD: required here because of inlining etc, TBD HI.hiiHIUsedImpModS = usedImpS } -- ; liftIO $ putStrLn $ "cpFlowCoreSemBeforeFold usedImpS " ++ show usedImpS -- ; liftIO $ putStrLn $ "cpFlowCoreSemBeforeFold introdModS " ++ show introdModS ; cpUpdCU modNm ( ecuStoreHIInfo hii' -- -- 20100717 AD: required here because of inlining etc, TBD . ecuStoreHIUsedImpS usedImpS . ecuStoreIntrodModS introdModS ) ; impNmL <- cpGenImpNmInfo modNm ; cpUpdCU modNm ( ecuStoreCore $ cmodSetImports impNmL core ) } {-# LINE 368 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-} cpFlowHILamMp :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpFlowHILamMp modNm = do { cr <- get ; let (ecu,crsi,opts,_) = crBaseInfo modNm cr coreInh = crsiCoreInh crsi hii = ecu ^. ecuHIInfo -- put back result: call info map (lambda arity, ...), overwriting previous entries ; cpUpdSI (\crsi -> crsi {crsiCoreInh = coreInh {Core2GrSem.lamMp_Inh_CodeAGItf = HI.hiiLamMp hii `lamMpUnionBindAspMp` Core2GrSem.lamMp_Inh_CodeAGItf coreInh}}) } {-# LINE 381 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-} cpFlowOptim :: EHCCompileRunner m => HsName -> EHCompilePhaseT m () cpFlowOptim modNm = do { cr <- get ; let (ecu,crsi,_,_) = crBaseInfo modNm cr optim = crsiOptim crsi moptim = panicJust "cpFlowOptim" $ ecuMbOptim ecu hii = ecu ^. ecuHIInfo optim' = optim hii' = hii ; when (isJust (ecuMbOptim ecu)) (do { cpUpdSI (\crsi -> crsi {crsiOptim = optim'}) ; cpUpdCU modNm $! ecuStoreHIInfo $! prepFlow hii' -- ; liftIO $ putStrLn (forceEval hii' `seq` "cpFlowOptim") }) }