uhc-light-1.1.9.4: src/UHC/Light/Compiler/HI.hs
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
}
)