module UHC.Light.Compiler.HI ( Visible (..) , HIInfoUsedModMp, HIInfo (..) , emptyHIInfo , hiiIsEmpty , hiiIdDefOccGam , mentrelToIdDefOccGam , hiiIdDefOccGamToHIIdGam, hiiIdDefOccGamFromHIIdGam , HIOrigin (..) , HIValidity (..) , sgetHIInfo , ImpHIMp , hiiUnion , hiiIncludeCacheOfImport ) where import UHC.Light.Compiler.Base.Common import UHC.Light.Compiler.Opts import UHC.Light.Compiler.Base.HsName.Builtin import UHC.Light.Compiler.NameAspect import UHC.Light.Compiler.Gam.Full import UHC.Light.Compiler.Gam.ClassDefaultGam import UHC.Light.Compiler.Ty import UHC.Light.Compiler.Base.Target import UHC.Light.Compiler.Core import UHC.Light.Compiler.LamInfo import UHC.Light.Compiler.Config import UHC.Light.Compiler.Module.ImportExport import UHC.Light.Compiler.Pred.CtxtRedOnly.ToCHR import UHC.Light.Compiler.CHR.CtxtRedOnly.Solve import qualified UHC.Light.Compiler.Gam.ClGam as Pr import qualified Data.Set as Set import qualified Data.Map as Map import qualified UHC.Util.Rel as Rel import qualified UHC.Util.FastSeq as Seq import UHC.Util.Utils import Control.Monad import UHC.Util.Binary import UHC.Util.Pretty import UHC.Util.Serialize import qualified UHC.Light.Compiler.Config as Cfg import qualified UHC.Light.Compiler.ConfigInternalVersions as Cfg import qualified UHC.Light.Compiler.SourceCodeSig as Sig {-# LINE 72 "src/ehc/HI.chs" #-} data Visible = VisibleNo | VisibleYes deriving Eq instance Show Visible where show VisibleNo = "visibleno" show VisibleYes = "visibleyes" {-# LINE 86 "src/ehc/HI.chs" #-} type HIInfoUsedModMp = (Map.Map HsName (Set.Set HsName)) -- | Encoding of info in .hi file, when changed also change {%{EH}ConfigInternalVersions} data HIInfo = HIInfo { hiiValidity :: !HIValidity -- a valid HI info? , hiiInternalVersions :: !Cfg.InternalVersionCombined -- internal version , hiiOrigin :: !HIOrigin -- where did the HI come from , hiiSrcSig :: !String -- compiler source signature (md5) , hiiTarget :: !Target -- for which backend the hi is generated , hiiTargetFlavor :: !TargetFlavor -- for which flavor the hi is generated , hiiCompiler :: !String -- compiler version info , hiiCompileFlags :: !String -- flags , hiiHasMain :: !Bool -- has file a main? , hiiModuleNm :: !HsName -- module name , hiiSrcTimeStamp :: !String -- timestamp of compiler source , hiiSrcVersionMajor :: !String -- major (etc) version numbers , hiiSrcVersionMinor :: !String , hiiSrcVersionMinorMinor :: !String , hiiSrcVersionSvn :: !String -- svn version , hiiExps :: !ModEntRel -- exported stuff , hiiHiddenExps :: !ModEntRel -- exported, but hidden otherwise (instances, optimized code variants, ...) , hiiFixityGam :: !FixityGam -- fixity of identifiers , hiiHIDeclImpModS :: !(Set.Set HsName) -- declared imports , hiiHIUsedImpModS :: !(Set.Set HsName) -- used imports, usually indirectly via renaming , hiiTransClosedUsedModMp :: !HIInfoUsedModMp -- used modules with their imports, required to be linked together, transitively closed/cached over imported modules , hiiTransClosedOrphanModS:: !(Set.Set HsName) -- orphan modules, required to read its .hi file, transitively closed/cached over imported modules , hiiMbOrphan :: !(Maybe (Set.Set HsName)) -- is orphan module, carrying the module names required , hiiDataGam :: !DataGam -- datatype info env , hiiValGam :: !ValGam -- value identifier environment , hiiTyGam :: !TyGam -- type identifier env , hiiTyKiGam :: !TyKiGam -- type/tyvar kind env , hiiPolGam :: !PolGam -- polarity env , hiiClGam :: !Pr.ClGam -- class env , hiiClDfGam :: !ClassDefaultGam -- class defaults env , hiiCHRStore :: !CHRStore -- rule database , hiiLamMp :: !LamMp -- codegen info for identifiers , hiiImpHIMp :: !ImpHIMp -- cache of HIInfo's of imported modules, filtered for visibility } deriving (Typeable) {-# LINE 145 "src/ehc/HI.chs" #-} emptyHIInfo :: HIInfo emptyHIInfo = HIInfo HIValidity_Absent Cfg.internalVersionCombined HIOrigin_FromFile "" defaultTarget defaultTargetFlavor "" "" False hsnUnknown "" "" "" "" "" Rel.empty Rel.empty emptyGam Set.empty Set.empty Map.empty Set.empty Nothing emptyGam emptyGam emptyGam emptyGam emptyGam emptyGam emptyGam emptyCHRStore Map.empty Map.empty {-# LINE 175 "src/ehc/HI.chs" #-} -- | not empty if ok hiiIsEmpty :: HIInfo -> Bool hiiIsEmpty hii = hiiValidity hii /= HIValidity_Ok {-# LINE 181 "src/ehc/HI.chs" #-} hiiIdDefOccGam :: HIInfo -> IdDefOccGam hiiIdDefOccGam hii = hiiIdDefOccGamFromHIIdGam $ mentrelToIdDefOccGam (hiiModuleNm hii) (hiiExps hii) {-# LINE 191 "src/ehc/HI.chs" #-} instance Show HIInfo where show _ = "HIInfo" instance PP HIInfo where pp i = "HIInfo" >#< ( "ModNm =" >#< pp ( hiiModuleNm i) >-< "DeclImp=" >#< ppCommas (Set.toList $ hiiHIDeclImpModS i) >-< "UsedImp=" >#< ppCommas (Set.toList $ hiiHIUsedImpModS i) >-< "AllUsed=" >#< ppAssocLV (assocLMapElt (ppCommas . Set.toList) $ Map.toList $ hiiTransClosedUsedModMp i) >-< "AllOrph=" >#< ppCommas (Set.toList $ hiiTransClosedOrphanModS i) >-< "MbOrph =" >#< ppCommas (maybe [] Set.toList $ hiiMbOrphan i) -- >-< "Exps=" >#< pp (hiiExps i) -- >-< "Exps(H)=" >#< pp (hiiHiddenExps i) -- >-< "ValGam =" >#< pp (hiiValGam i) -- >-< "TyGam =" >#< pp (hiiTyGam i) -- >-< "Cached =" >#< ppAssocLV (assocLMapElt pp $ Map.toList $ hiiImpHIMp i) ) {-# LINE 232 "src/ehc/HI.chs" #-} type ImpHIMp = Map.Map HsName HIInfo {-# LINE 237 "src/ehc/HI.chs" #-} -- | combine HI info for a single module, as extracted from the cached hiiImpHIMp of the module importing these combined modules hiiUnion :: HIInfo -> HIInfo -> HIInfo hiiUnion m1 m2 = m1 { hiiFixityGam = hiiFixityGam m1 `gamUnion` hiiFixityGam m2 -- , hiiIdDefHIIdGam = hiiIdDefHIIdGam m1 `gamUnion` hiiIdDefHIIdGam m2 , hiiValGam = hiiValGam m1 `gamUnion` hiiValGam m2 , hiiTyGam = hiiTyGam m1 `gamUnion` hiiTyGam m2 , hiiTyKiGam = hiiTyKiGam m1 `gamUnion` hiiTyKiGam m2 , hiiPolGam = hiiPolGam m1 `gamUnion` hiiPolGam m2 , hiiClGam = hiiClGam m1 `gamUnion` hiiClGam m2 , hiiClDfGam = hiiClDfGam m1 `gamUnion` hiiClDfGam m2 , hiiCHRStore = hiiCHRStore m1 `chrStoreUnion` hiiCHRStore m2 , hiiDataGam = hiiDataGam m1 `gamUnion` hiiDataGam m2 , hiiLamMp = hiiLamMp m1 `Map.union` hiiLamMp m2 } {-# LINE 264 "src/ehc/HI.chs" #-} -- | restrict envs to the ones being in the filter map, so only those visible relative to that map remain hiiRestrictToFilterMp :: ModEntRelFilterMp -> HIInfo -> HIInfo hiiRestrictToFilterMp mfm hii = hii { hiiFixityGam = fg expVT $ hiiFixityGam hii -- , hiiIdDefHIIdGam = fg (\o -> exp (ioccKind o) (ioccNm o)) -- $ hiiIdDefHIIdGam hii , hiiValGam = fg expV $ hiiValGam hii , hiiTyGam = fg expT $ hiiTyGam hii , hiiTyKiGam = fg expT' $ hiiTyKiGam hii , hiiPolGam = fg expT $ hiiPolGam hii , hiiClGam = fg expC $ hiiClGam hii , hiiClDfGam = fg expC $ hiiClDfGam hii , hiiDataGam = fg expT $ hiiDataGam hii , hiiLamMp = fm expV $ hiiLamMp hii } where exp k = (`Set.member` Map.findWithDefault Set.empty k mfm) expV = exp IdOcc_Val expT = exp IdOcc_Type expT' = maybe False (exp IdOcc_Type) . tyKiKeyMbName expVT x= expV x || expT x expC = expT -- exp IdOcc_Class fg p = fst . gamPartition (\k _ -> p k) fm p = Map.filterWithKey (\k _ -> p k) {-# LINE 302 "src/ehc/HI.chs" #-} -- | restrict envs to the ones being exported, so only the visible part remains hiiRestrictToExported :: HIInfo -> HIInfo hiiRestrictToExported hii = hiiRestrictToFilterMp (mentrelToFilterMp [] (hiiExps hii) `mentrelFilterMpUnion` mentrelToFilterMp [] (hiiHiddenExps hii)) hii {-# LINE 308 "src/ehc/HI.chs" #-} -- | include the imported HIInfos in this one, restricted to their exports, to be done just before saving hiiIncludeCacheOfImport :: (HsName -> HIInfo) -> ModEntRelFilterMp -> HIInfo -> HIInfo hiiIncludeCacheOfImport imp mfm hii = hii { hiiImpHIMp = Map.map reset $ Map.unions [top, subtop] } where -- imports of this module top = Map.unions [ Map.singleton i $ hiiRestrictToFilterMp mfm $ {- (\x -> tr "hiiIncludeCacheOfImport.1" (i >#< x) x) $ -} imp i | i <- Set.toList $ hiiHIDeclImpModS hii `Set.union` hiiHIUsedImpModS hii ] -- the closure of the imports w.r.t. import relationship subtop = Map.map (hiiRestrictToFilterMp mfm) $ Map.unionsWith hiiUnion $ map hiiImpHIMp $ Map.elems top -- reset some info in cached hii's reset hii = hii { hiiImpHIMp = Map.empty , hiiExps = Rel.empty , hiiHiddenExps = Rel.empty , hiiHIDeclImpModS = Set.empty , hiiHIUsedImpModS = Set.empty , hiiCHRStore = emptyCHRStore -- this cannot be, but no solution for filtering this... , hiiSrcSig = "" , hiiCompiler = "" , hiiSrcTimeStamp = "" , hiiSrcVersionMajor = "" , hiiSrcVersionMinor = "" , hiiSrcVersionMinorMinor = "" , hiiSrcVersionSvn = "" } {-# LINE 344 "src/ehc/HI.chs" #-} mentrelToIdDefOccGam :: HsName -> ModEntRel -> Gam IdOcc IdOcc -- IdDefOccGam mentrelToIdDefOccGam modNm r = gamFromAssocL [ ( IdOcc n' k -- , mkIdDefOcc (IdOcc (ioccNm $ mentIdOcc e) k) IdAsp_Any nmLevOutside emptyRange , IdOcc (ioccNm $ mentIdOcc e) k ) | (n,e) <- Rel.toList r , let k = ioccKind $ mentIdOcc e n' = hsnSetQual modNm n ] {-# LINE 362 "src/ehc/HI.chs" #-} hiiIdDefOccGamToHIIdGam :: IdDefOccGam -> Gam IdOcc IdOcc hiiIdDefOccGamToHIIdGam = gamMap (\(k,v) -> (k,doccOcc v)) hiiIdDefOccGamFromHIIdGam :: Gam IdOcc IdOcc -> IdDefOccGam hiiIdDefOccGamFromHIIdGam = gamMap (\(k,v) -> (k,mkIdDefOcc v IdAsp_Any nmLevOutside emptyRange)) {-# LINE 374 "src/ehc/HI.chs" #-} data HIOrigin = HIOrigin_FromFile -- from .hi file | HIOrigin_FromImportedBy HsNameS -- reconstructed from modules which imported this hi deriving (Eq,Show,Typeable) {-# LINE 381 "src/ehc/HI.chs" #-} data HIValidity = HIValidity_Ok -- ok | HIValidity_WrongMagic -- wrong magic number | HIValidity_Inconsistent -- inconsistent with compiler | HIValidity_Absent -- not available deriving (Eq,Enum,Show,Typeable) {-# LINE 394 "src/ehc/HI.chs" #-} gamFlatten :: Ord k => Gam k v -> Gam k v gamFlatten = id -- gamFromAssocL . gamToAssocL {-# LINE 403 "src/ehc/HI.chs" #-} instance Serialize HIValidity where sput = sputEnum8 sget = sgetEnum8 {-# LINE 409 "src/ehc/HI.chs" #-} sgetHIInfo :: EHCOpts -> SGet HIInfo sgetHIInfo opts = do { hi_magic <- sequence $ replicate (length Cfg.magicNumberHI) sgetWord8 ; if hi_magic == Cfg.magicNumberHI then do { hi_sig <- sget ; hi_ts <- sget ; hi_iv <- sget ; hi_t <- sget ; hi_tv <- sget ; hi_fl <- sget ; hi_comp <- sget ; if ( {- hi_sig == Sig.sig && hi_ts == Sig.timestamp && -} hi_iv == hiiInternalVersions emptyHIInfo && hi_t == ehcOptTarget opts && hi_tv == ehcOptTargetFlavor opts ) || not (ehcOptHiValidityCheck opts) then do { hi_nm <- sget ; hi_hm <- sget ; hi_m <- sget ; hi_mm <- sget ; hi_mmm <- sget ; hi_svn <- sget ; e <- sget ; he <- sget ; fg <- sget ; impd <- sget ; impu <- sget ; tclused <- sget ; tclorph <- sget ; isorph <- sget ; dg <- sget ; vg <- sget ; tg <- sget ; tkg <- sget ; pg <- sget ; cg <- sget ; cdg <- sget ; cs <- sget ; am <- sget ; him <- sget ; return (emptyHIInfo { hiiValidity = HIValidity_Ok , hiiSrcSig = hi_sig , hiiCompiler = hi_comp , hiiCompileFlags = hi_fl , hiiTarget = hi_t , hiiTargetFlavor = hi_tv , hiiHasMain = hi_hm , hiiSrcTimeStamp = hi_ts , hiiInternalVersions = hi_iv , hiiModuleNm = hi_nm , hiiSrcVersionMajor = hi_m , hiiSrcVersionMinor = hi_mm , hiiSrcVersionMinorMinor = hi_mmm , hiiSrcVersionSvn = hi_svn , hiiExps = e , hiiHiddenExps = he , hiiFixityGam = fg , hiiHIDeclImpModS = impd , hiiHIUsedImpModS = impu , hiiTransClosedUsedModMp = tclused , hiiTransClosedOrphanModS= tclorph , hiiMbOrphan = isorph , hiiDataGam = dg , hiiValGam = vg , hiiTyGam = tg , hiiTyKiGam = tkg , hiiPolGam = pg , hiiClGam = cg , hiiClDfGam = cdg , hiiCHRStore = cs , hiiLamMp = am , hiiImpHIMp = him }) } else return $ emptyHIInfo { hiiValidity = HIValidity_Inconsistent , hiiSrcSig = hi_sig , hiiSrcTimeStamp = hi_ts , hiiInternalVersions = hi_iv , hiiCompileFlags = hi_fl , hiiCompiler = hi_comp , hiiTarget = hi_t , hiiTargetFlavor = hi_tv } } else return $ emptyHIInfo { hiiValidity = HIValidity_WrongMagic } } {-# LINE 536 "src/ehc/HI.chs" #-} instance Serialize HIInfo where sput (HIInfo { hiiSrcSig = hi_sig , hiiTarget = hi_t , hiiTargetFlavor = hi_tv , hiiCompiler = hi_comp , hiiCompileFlags = hi_fl , hiiModuleNm = hi_nm , hiiHasMain = hi_hm , hiiSrcTimeStamp = hi_ts , hiiInternalVersions = hi_iv , hiiSrcVersionMajor = hi_m , hiiSrcVersionMinor = hi_mm , hiiSrcVersionMinorMinor = hi_mmm , hiiSrcVersionSvn = hi_svn , hiiExps = e , hiiHiddenExps = he , hiiFixityGam = fg , hiiHIDeclImpModS = impd , hiiHIUsedImpModS = impu , hiiTransClosedUsedModMp = tclused , hiiTransClosedOrphanModS= tclorph , hiiMbOrphan = isorph , hiiDataGam = dg , hiiValGam = vg , hiiTyGam = tg , hiiTyKiGam = tkg , hiiPolGam = pg , hiiClGam = cg , hiiClDfGam = cdg , hiiCHRStore = cs , hiiLamMp = am , hiiImpHIMp = him }) = mapM sputWord8 Cfg.magicNumberHI >> sput hi_sig >> sput hi_ts >> sput hi_iv >> sput hi_t >> sput hi_tv >> sput hi_fl >> sput hi_comp >> sput hi_nm >> sput hi_hm >> sput hi_m >> sput hi_mm >> sput hi_mmm >> sput hi_svn >> sput e >> sput he >> sput (gamFlatten fg) >> sput impd >> sput impu >> sput tclused >> sput tclorph >> sput isorph >> sput (gamFlatten dg) >> sput (gamFlatten vg) >> sput (gamFlatten tg) >> sput (gamFlatten tkg) >> sput (gamFlatten pg) >> sput (gamFlatten cg) >> sput (gamFlatten cdg) >> sput cs >> sput am >> sput him sget = sgetHIInfo (defaultEHCOpts { ehcOptHiValidityCheck = False } )