module UHC.Light.Compiler.EHC.CompilePhase.Semantics ( cpFoldCore2Grin , cpFoldEH , cpFoldHs , 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 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.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 63 "src/ehc/EHC/CompilePhase/Semantics.chs" #-} cpFoldCore2Grin :: HsName -> EHCompilePhase () 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 85 "src/ehc/EHC/CompilePhase/Semantics.chs" #-} cpFoldCoreMod :: HsName -> EHCompilePhase () 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 -- ; lift $ putStrLn $ "cpFoldCoreMod " ++ show hasMain ; when (isJust mbCore) (cpUpdCU modNm ( ecuStoreCoreSemMod coreSem . ecuSetHasMain hasMain . ecuStoreMod mod )) } {-# LINE 109 "src/ehc/EHC/CompilePhase/Semantics.chs" #-} cpFoldEH :: HsName -> EHCompilePhase () 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 136 "src/ehc/EHC/CompilePhase/Semantics.chs" #-} cpFoldHs :: HsName -> EHCompilePhase () 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) (lift $ putStrLn (show modNm ++ " hasMain=" ++ show hasMain)) -- ; when hasMain (crSetAndCheckMain modNm) }) } {-# LINE 183 "src/ehc/EHC/CompilePhase/Semantics.chs" #-} cpFoldHsMod :: HsName -> EHCompilePhase () 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 211 "src/ehc/EHC/CompilePhase/Semantics.chs" #-} cpFoldHIInfo :: HsName -> EHCompilePhase () 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) (lift $ putStrLn (show modNm ++ ": hi imps, decl=" ++ show (HI.hiiHIDeclImpModS hiInfo) ++ ", used=" ++ show (HI.hiiHIUsedImpModS hiInfo) ) ) }) }