uhc-light-1.1.9.1: src/UHC/Light/Compiler/EHC/CompilePhase/FlowBetweenPhase.hs
module UHC.Light.Compiler.EHC.CompilePhase.FlowBetweenPhase
( cpFlowEHSem1
, cpFlowHsSem1
, cpFlowHISem
, cpFlowCoreModSem
, 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.Main 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 qualified UHC.Util.FastSeq as Seq
import UHC.Light.Compiler.EHC.CompilePhase.Module(cpUpdHiddenExports)
{-# LINE 82 "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 103 "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'})
; bUpdAlreadyFlowIntoCRSI modNm ASTType_HS ASTSemFlowStage_BetweenModule
; cpUpdCU modNm $! ecuStoreHIInfo hii'
-- ; liftIO $ putStrLn (forceEval hii' `seq` "cpFlowHsSem1")
})
-- ; liftIO $ putWidthPPLn 120 (ppGam $ EHSem.idQualGam_Inh_AGItf $ ehInh')
}
{-# LINE 147 "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
cenv = crsi ^. crsiCEnv
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
cenv' = ( cenvDataGam ^$= (dg `gamUnionFlow`) )
. ( cenvLamMp ^$= (lm `lamMpUnionBindAspMp`) ) -- assumption: no duplicates, otherwise merging as done later has to be done
$ cenv
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.dataGam_Inh_AGItf = cenv' ^. cenvDataGam
, 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
}
; when (isJust (_ecuMbEHSem ecu))
(do { cpUpdSI
(\crsi -> crsi
{ _crsiCEnv = cenv'
, _crsiEHInh = ehInh'
}
)
; bUpdAlreadyFlowIntoCRSI modNm ASTType_EH ASTSemFlowStage_BetweenModule
; cpUpdCU modNm ( ecuStoreHIInfo hii'
. ecuStoreHIUsedImpS usedImpS
. ecuStoreUsedNames mentrelFilterMp
)
-- put back additional hidden exports
; cpUpdHiddenExports modNm $ Seq.toList $ EHSem.gathHiddenExports_Syn_AGItf ehSem
; bUpdAlreadyFlowIntoCRSI modNm ASTType_EH ASTSemFlowStage_PerModule
})
}
{-# 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
cenv = crsi ^. crsiCEnv
cenv' = ( cenvDataGam ^$= (HI.hiiDataGam hiInfo `gamUnionFlow`) )
. ( cenvLamMp ^$= (HI.hiiLamMp hiInfo `lamMpUnionBindAspMp`) )
$ cenv
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.dataGam_Inh_AGItf = cenv' ^. cenvDataGam
, 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
}
optim = crsiOptim crsi
optim' = optim
; when (isJust (_ecuMbPrevHIInfo ecu))
(do { cpUpdSI (\crsi -> crsi { _crsiEHInh = ehInh'
, _crsiHSInh = hsInh'
, _crsiCEnv = cenv'
, crsiOptim = optim'
})
})
}
{-# LINE 296 "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
mbCoreModSem = _ecuMbCoreSemMod ecu
; when (isJust mbCoreModSem) $ do
{ let coreModSem = fromJust mbCoreModSem
cenv = cenvDataGam ^$= (`gamUnionFlow` Core2ChkSem.gathDataGam_Syn_CodeAGItf coreModSem) $ crsi ^. crsiCEnv
; cpUpdSI $
( crsiCEnv ^= cenv )
}
}
{-# LINE 341 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-}
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 <- cpGenImportNameInfo modNm
-- ; impNmL <- bcall $ ImportNameInfo (mkPrevFileSearchKeyWithName modNm) (ehcOptOptimizationScope opts)
; cpUpdCU modNm ( ecuStoreCore $ cmodSetImports impNmL core
)
}
{-# LINE 371 "src/ehc/EHC/CompilePhase/FlowBetweenPhase.chs" #-}
cpFlowHILamMp :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFlowHILamMp modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
cenv = cenvLamMp ^$= (HI.hiiLamMp hii `lamMpUnionBindAspMp`) $ crsi ^. crsiCEnv -- assumption: old info can be overridden, otherwise merge should be done here
hii = ecu ^. ecuHIInfo
-- put back result: call info map (lambda arity, ...), overwriting previous entries
; cpUpdSI $
( crsiCEnv ^= cenv )
}
{-# LINE 385 "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")
})
}