uhc-light-1.1.8.7: 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 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 70 "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 = crsiHereUID crsi
, Core2GrSem.opts_Inh_CodeAGItf = opts
, Core2GrSem.importUsedModules_Inh_CodeAGItf = ecuImportUsedModules ecu
})
; when (isJust mbCore)
(cpUpdCU modNm ( ecuStoreCoreSem coreSem
))
}
{-# LINE 92 "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 117 "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 141 "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 $ crsiEHInh crsi
}
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 165 "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)
((crsiEHInh crsi)
{ EHSem.moduleNm_Inh_AGItf = ecuModNm ecu
, EHSem.gUniq_Inh_AGItf = crsiHereUID crsi
, 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 192 "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 = crsiHSInh crsi
hsSem = HSSem.wrap_AGItf (HSSem.sem_AGItf $ panicJust "cpFoldHs" mbHS)
(inh { HSSem.opts_Inh_AGItf = opts
, HSSem.gUniq_Inh_AGItf = crsiHereUID crsi
, 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 239 "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 = crsiHereUID crsi
, 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 267 "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)
) )
})
}