uhc-light-1.1.9.3: src/UHC/Light/Compiler/EHC/CompilePhase/Semantics.hs
module UHC.Light.Compiler.EHC.CompilePhase.Semantics
( cpFoldCore2CoreRun
, cpFoldEH
, cpFoldHs
, 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.Main 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
{-# LINE 99 "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
inhLbl = crsiCoreRunState ^* crcrsiNm2RefMp
core2RunInh = crsi ^. inhLbl
(corerun,nm2ref,sem) = Core2CoreRunSem.cmod2CoreRun' opts hasMain Nothing core2RunInh core
core2RunInh' = nm2ref `CoreRun.nm2refUnion` core2RunInh
; when (isJust mbCore) $ do
-- between module flow part
cpUpdSI $ inhLbl ^= core2RunInh'
-- cpUpdSI (\crsi -> crsi {_crsiCore2RunInh = core2RunInh'})
-- per module part
cpUpdCU modNm ( ecuStoreCoreRun corerun
. ecuStoreCore2CoreRunSem sem
)
}
{-# LINE 149 "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
}
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 172 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldEH :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldEH modNm
= do { cr <- get
; let (ecu,crsi,opts,_) = crBaseInfo modNm cr
; mieimpl <- cpGenModuleImportExportImpl modNm
-- ; mieimpl <- bcall $ ImportExportImpl (mkPrevFileSearchKeyWithName modNm) (ehcOptOptimizationScope opts)
; let 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 200 "src/ehc/EHC/CompilePhase/Semantics.chs" #-}
cpFoldHs :: EHCCompileRunner m => HsName -> EHCompilePhaseT m ()
cpFoldHs modNm
= do { cr <- get
-- ; isTopMod <- bcall $ IsTopMod $ mkPrevFileSearchKeyWithName modNm
; 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 = {- isTopMod -- -} _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) $
ecuSrcDeclImpNmS ecu)
-- . ecuSetHasMain hasMain
)
; when (ehcOptVerbosity opts >= VerboseDebug)
(liftIO $ putStrLn (show modNm ++ " hasMain=" ++ show hasMain))
-- ; when hasMain (crSetAndCheckMain modNm)
})
}
{-# LINE 250 "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 278 "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)
) )
})
}