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) ) ) }) }