uhc-light-1.1.8.10: src/UHC/Light/Compiler/EHC/CompilePhase/Semantics.hs
module UHC.Light.Compiler.EHC.CompilePhase.Semantics
( cpFoldCore2Grin
, cpFoldCore2CoreRun
, cpFoldEH
, cpFoldHs
, cpFoldCoreRunMod
, cpFoldCoreMod
, cpFoldHsMod
, cpFoldHIInfo )
where
import UHC.Util.Lens
import Control.Monad.State
import qualified Data.Map as Map
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 as Core
import qualified UHC.Light.Compiler.Core.ToGrin as Core2GrSem
import qualified UHC.Light.Compiler.Core.ToCoreRun as Core2CoreRunSem
import qualified UHC.Light.Compiler.CoreRun as CoreRun
import qualified Data.Set as Set
import UHC.Light.Compiler.EHC.CompilePhase.Common
import qualified UHC.Light.Compiler.Core.Check as Core2ChkSem
import qualified UHC.Light.Compiler.CoreRun.Check as CoreRun2ChkSem
import qualified UHC.Light.Compiler.HI as HI
import qualified UHC.Util.Rel as Rel
import UHC.Light.Compiler.Module.ImportExport
import qualified UHC.Light.Compiler.HS.ModImpExp as HSSemMod
import UHC.Light.Compiler.Base.Debug
import UHC.Util.Pretty
{-# LINE 72 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldCore2Grin :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldCore2Grin modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
mbCore = _ecuMbCore ecu
core = panicJust "cpFoldCore2Grin" mbCore
coreInh = crsiCoreInh crsi
coreSem = Core2GrSem.wrap_CodeAGItf
(Core2GrSem.sem_CodeAGItf (Core.CodeAGItf_AGItf core))
(coreInh { Core2GrSem.gUniq_Inh_CodeAGItf = crsi ^. crsiHereUID
, Core2GrSem.opts_Inh_CodeAGItf = opts
, Core2GrSem.importUsedModules_Inh_CodeAGItf = ecuImportUsedModules ecu
})
; when (isJust mbCore)
(cpUpdCU modNm ( ecuStoreCoreSem coreSem
))
}
{-# LINE 94 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldCore2CoreRun :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldCore2CoreRun modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
mbCore = _ecuMbCore ecu
hasMain = ecuHasMain ecu
core = panicJust "cpFoldCore2CoreRun" mbCore
core2RunInh = crsiCore2RunInh crsi
(corerun,nm2ref,sem) = Core2CoreRunSem.cmod2CoreRun' opts hasMain 0 core2RunInh core
core2RunInh' = nm2ref `CoreRun.nm2refUnion` core2RunInh
; when (isJust mbCore) $ do
-- between module flow part
cpUpdSI (\crsi -> crsi {crsiCore2RunInh = core2RunInh'})
-- per module part
cpUpdCU modNm ( ecuStoreCoreRun corerun
. ecuStoreCore2CoreRunSem sem
)
}
{-# LINE 119 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldCoreRunMod :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldCoreRunMod modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
mbCoreRun= _ecuMbCoreRun ecu
core = panicJust "cpFoldCoreRunMod" mbCoreRun
inh = CoreRun2ChkSem.Inh_AGItf
{ CoreRun2ChkSem.opts_Inh_AGItf = opts
, CoreRun2ChkSem.moduleNm_Inh_AGItf = modNm
-- , CoreRun2ChkSem.dataGam_Inh_AGItf = EHSem.dataGam_Inh_AGItf $ _crsiEHInh crsi
}
crrSem = CoreRun2ChkSem.crmodCheck' inh core
hasMain = CoreRun2ChkSem.hasMain_Syn_AGItf crrSem
mod = CoreRun2ChkSem.mod_Syn_AGItf crrSem
-- ; liftIO $ putStrLn $ "cpFoldCoreRunMod " ++ show hasMain
; when (isJust mbCoreRun)
(cpUpdCU modNm ( ecuStoreCoreRunSemMod crrSem
. ecuSetHasMain hasMain
. ecuStoreMod mod
))
}
{-# LINE 143 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldCoreMod :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldCoreMod modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
mbCore = _ecuMbCore ecu
core = panicJust "cpFoldCoreMod" mbCore
inh = Core2ChkSem.Inh_CodeAGItf
{ Core2ChkSem.opts_Inh_CodeAGItf = opts
, Core2ChkSem.moduleNm_Inh_CodeAGItf = modNm
, Core2ChkSem.dataGam_Inh_CodeAGItf = EHSem.dataGam_Inh_AGItf $ crsi ^. crsiEHInh
}
coreSem = Core2ChkSem.cmodCheck' inh core
hasMain = Core2ChkSem.hasMain_Syn_CodeAGItf coreSem
mod = Core2ChkSem.mod_Syn_CodeAGItf coreSem
-- ; liftIO $ putStrLn $ "cpFoldCoreMod " ++ show hasMain
; when (isJust mbCore)
(cpUpdCU modNm ( ecuStoreCoreSemMod coreSem
. ecuSetHasMain hasMain
. ecuStoreMod mod
))
}
{-# LINE 167 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldEH :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldEH modNm
= do { cr <- get
; mieimpl <- cpGenModuleImportExportImpl modNm
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
mbEH = _ecuMbEH ecu
ehSem = EHSem.wrap_AGItf (EHSem.sem_AGItf $ panicJust "cpFoldEH" mbEH)
((crsi ^. crsiEHInh)
{ EHSem.moduleNm_Inh_AGItf = ecuModNm ecu
, EHSem.gUniq_Inh_AGItf = crsi ^. crsiHereUID
, EHSem.opts_Inh_AGItf = opts
, EHSem.importUsedModules_Inh_AGItf = ecuImportUsedModules ecu
, EHSem.moduleImportExportImpl_Inh_AGItf = mieimpl
, EHSem.isMainMod_Inh_AGItf = ecuIsMainMod ecu
})
; when (isJust mbEH)
(cpUpdCU modNm $! ecuStoreEHSem $! ehSem)
}
{-# LINE 194 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldHs :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldHs modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
mbHS = _ecuMbHS ecu
inh = crsi ^. crsiHSInh
hsSem = HSSem.wrap_AGItf (HSSem.sem_AGItf $ panicJust "cpFoldHs" mbHS)
(inh { HSSem.opts_Inh_AGItf = opts
, HSSem.gUniq_Inh_AGItf = crsi ^. crsiHereUID
, HSSem.moduleNm_Inh_AGItf = modNm
, HSSem.isTopMod_Inh_AGItf = ecuIsTopMod ecu
, HSSem.modInScope_Inh_AGItf = inscps
, HSSem.modEntToOrig_Inh_AGItf = exps
, HSSem.topInstanceNmL_Inh_AGItf = modInstNmL (ecuMod ecu)
})
where mmi = panicJust "cpFoldHs.crsiModMp" $ Map.lookup modNm $ crsiModMp crsi
inscps = Rel.toDomMap --- $ (\v -> tr "XX mmiInscps mmi" (pp v ) v)
$ mmiInscps
--- $ (\v -> tr "XX mmi" (pp v ) v)
$ mmi
exps = Rel.toRngMap $ Rel.restrictRng (\o -> let mq = hsnQualifier (ioccNm o) in isJust mq && fromJust mq /= modNm)
$ Rel.mapRng mentIdOcc $ mmiExps mmi
hasMain= HSSem.mainValExists_Syn_AGItf hsSem
; when (isJust mbHS)
(do { cpUpdCU modNm ( ecuStoreHSSem hsSem
. ecuStoreHIDeclImpS ( -- (\v -> tr "YY" (pp $ Set.toList v) v) $
ecuHSDeclImpNmS ecu)
-- . ecuSetHasMain hasMain
)
; when (ehcOptVerbosity opts >= VerboseDebug)
(liftIO $ putStrLn (show modNm ++ " hasMain=" ++ show hasMain))
-- ; when hasMain (crSetAndCheckMain modNm)
})
}
{-# LINE 241 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldHsMod :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldHsMod modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
mbHS = _ecuMbHS ecu
inh = crsiHSModInh crsi
hsSemMod = HSSemMod.wrap_AGItf (HSSemMod.sem_AGItf $ panicJust "cpFoldHsMod" mbHS)
(inh { HSSemMod.gUniq_Inh_AGItf = crsi ^. crsiHereUID
, HSSemMod.moduleNm_Inh_AGItf = modNm
})
hasMain= HSSemMod.mainValExists_Syn_AGItf hsSemMod
pragmas = HSSemMod.fileHeaderPragmas_Syn_AGItf hsSemMod
(ecuOpts,modifiedOpts)
= ehcOptUpdateWithPragmas pragmas opts
; when (isJust mbHS)
(cpUpdCU modNm ( ecuStoreHSSemMod hsSemMod
. ecuSetHasMain hasMain
. ecuStorePragmas pragmas
. (if modifiedOpts then ecuStoreOpts ecuOpts else id)
) )
}
{-# LINE 269 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldHIInfo :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldHIInfo modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
mbHIInfo = _ecuMbPrevHIInfo ecu
hiInfo = panicJust "cpFoldHIInfo" mbHIInfo
hasMain = HI.hiiHasMain hiInfo
; when (isJust mbHIInfo && HI.hiiValidity hiInfo == HI.HIValidity_Ok)
(do { let mm = crsiModMp crsi
mmi = Map.findWithDefault emptyModMpInfo modNm mm
mmi' = mkModMpInfo modNm
(mmiInscps mmi)
( -- (\v -> tr "cpFoldHIInfo.hiiExps" (pp v) v) $
HI.hiiExps hiInfo)
(HI.hiiHiddenExps hiInfo)
-- ; when hasMain (crSetAndCheckMain modNm)
; cpUpdSI (\crsi -> crsi {crsiModMp = Map.insert modNm mmi' mm})
; cpUpdCU modNm ( ecuStorePrevHIInfo hiInfo
. ecuStoreHIDeclImpS (HI.hiiHIDeclImpModS hiInfo)
. ecuStoreHIUsedImpS (HI.hiiHIUsedImpModS hiInfo)
. ecuSetHasMain hasMain
)
; when (ehcOptVerbosity opts >= VerboseDebug)
(liftIO $ putStrLn
(show modNm
++ ": hi imps, decl=" ++ show (HI.hiiHIDeclImpModS hiInfo)
++ ", used=" ++ show (HI.hiiHIUsedImpModS hiInfo)
) )
})
}