summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/BinIface.hs18
-rw-r--r--compiler/iface/IfaceSyn.hs93
-rw-r--r--compiler/iface/LoadIface.hs8
-rw-r--r--compiler/iface/MkIface.hs87
-rw-r--r--compiler/iface/TcIface.hs4
5 files changed, 186 insertions, 24 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index faee723bd2..0f7073f15c 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -148,7 +148,15 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
wantedGot "Way" way_descr check_way ppr
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
- getWithUserData ncu bh
+
+ extFields_p <- get bh
+
+ mod_iface <- getWithUserData ncu bh
+
+ seekBin bh extFields_p
+ extFields <- get bh
+
+ return mod_iface{mi_ext_fields = extFields}
-- | This performs a get action after reading the dictionary and symbol
@@ -200,8 +208,16 @@ writeBinIface dflags hi_path mod_iface = do
let way_descr = getWayDescr dflags
put_ bh way_descr
+ extFields_p_p <- tellBin bh
+ put_ bh extFields_p_p
putWithUserData (debugTraceMsg dflags 3) bh mod_iface
+
+ extFields_p <- tellBin bh
+ putAt bh extFields_p_p extFields_p
+ seekBin bh extFields_p
+ put_ bh (mi_ext_fields mod_iface)
+
-- And send the result to the file
writeBinMem bh hi_path
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index f691300157..9662667172 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -22,6 +22,7 @@ module IfaceSyn (
IfaceAxBranch(..),
IfaceTyConParent(..),
IfaceCompleteMatch(..),
+ IfaceModGuts(..),
-- * Binding names
IfaceTopBndr,
@@ -57,7 +58,7 @@ import Name
import CostCentre
import Literal
import ForeignCall
-import Annotations( AnnPayload, AnnTarget )
+import Annotations( AnnPayload, AnnTarget, Annotation )
import BasicTypes
import Outputable
import Module
@@ -73,6 +74,16 @@ import Lexeme (isLexSym)
import TysWiredIn ( constraintKindTyConName )
import Util (seqList)
+import ByteCodeTypes
+import DriverPhases
+import GHC.ForeignSrcLang.Type
+import GHC.Hs.Doc ( ArgDocMap, DeclDocMap, HsDocString )
+import Avail
+import RdrName
+import {-# SOURCE #-} HscTypes
+import NameEnv
+import DynFlags
+
import Control.Monad
import System.IO.Unsafe
import Control.DeepSeq
@@ -571,7 +582,50 @@ type family (==) (a :: k) (b :: k) :: Bool
-- incompatible with: #1, #0
The comment after an equation refers to all previous equations (0-indexed)
that are incompatible with it.
++-}
+
+{-
++************************************************************************
++* *
++ Phases
++* *
++************************************************************************
++-}
+
+data IfaceModGuts = IfaceModGuts {
+ img_module :: !Module,
+ img_hsc_src :: HscSource,
+ img_loc :: SrcSpan,
+ img_exports :: ![AvailInfo],
+ img_deps :: !Dependencies,
+ img_usages :: ![Usage],
+ img_used_th :: !Bool,
+ img_rdr_env :: !GlobalRdrEnv,
+ img_fix_env :: !FixityEnv,
+ img_tcs :: ![IfaceTyCon],
+ img_insts :: ![IfaceClsInst],
+ img_fam_insts :: ![IfaceFamInst],
+ img_patsyns :: ![IfaceDecl],
+ img_rules :: ![IfaceRule],
+ img_binds :: ![IfaceBinding],
+ img_foreign :: !ForeignStubs,
+ img_foreign_files :: ![(ForeignSrcLang, FilePath)],
+ img_warns :: !Warnings,
+ img_anns :: [Annotation],
+ img_complete_sigs :: [CompleteMatch],
+ img_hpc_info :: !HpcInfo,
+ img_modBreaks :: !(Maybe ModBreaks),
+ img_inst_env :: [IfaceClsInst],
+ img_fam_inst_env :: [IfaceFamInst],
+ img_safe_haskell :: SafeHaskellMode,
+ img_trust_pkg :: Bool,
+ img_doc_hdr :: !(Maybe HsDocString),
+ img_decl_docs :: !DeclDocMap,
+ img_arg_docs :: !ArgDocMap
+ }
+
+{-
************************************************************************
* *
Printing IfaceDecl
@@ -2418,6 +2472,43 @@ instance Binary IfaceCompleteMatch where
put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts
get bh = IfaceCompleteMatch <$> get bh <*> get bh
+instance Binary IfaceModGuts where
+ put_ bh (IfaceModGuts f1 f2 f3 f4 f5 f6 f7 _f8 _f9 f10 f11 f12 f13 f14 f15 f16 f17 f18
+ f19 f20 f21 _f22 f23 f24 f25 f26 f27 f28 f29) = do
+ put_ bh f1
+ put_ bh f2
+ put_ bh f3
+ put_ bh f4
+ put_ bh f5
+ put_ bh f6
+ put_ bh f7
+ -- put_ bh f8
+ -- put_ bh f9
+ put_ bh f10
+ put_ bh f11
+ put_ bh f12
+ put_ bh f13
+ put_ bh f14
+ put_ bh f15
+ put_ bh f16
+ put_ bh f17
+ put_ bh f18
+ put_ bh f19
+ put_ bh f20
+ put_ bh f21
+ put_ bh f23
+ put_ bh f24
+ put_ bh f25
+ put_ bh f26
+ put_ bh f27
+ put_ bh f28
+ put_ bh f29
+
+ get bh = IfaceModGuts <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+ <*> get bh <*> return emptyOccEnv <*> return emptyNameEnv <*> get bh <*> get bh <*> get bh
+ <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh
+ <*> get bh <*> get bh <*> get bh <*> return Nothing <*> get bh <*> get bh
+ <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh
{-
************************************************************************
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 8d327e528d..06cdb90800 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -48,6 +48,7 @@ import HscTypes
import BasicTypes hiding (SuccessFlag(..))
import TcRnMonad
+import Binary ( BinData(..) )
import Constants
import PrelNames
import PrelInfo
@@ -83,6 +84,7 @@ import Plugins
import Control.Monad
import Control.Exception
import Data.IORef
+import Data.Map ( toList )
import System.FilePath
{-
@@ -1155,6 +1157,7 @@ pprModIface iface@ModIface{ mi_final_exts = exts }
, text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
, text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
, text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
+ , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))
]
where
pp_hsc_src HsBootFile = text "[boot]"
@@ -1244,6 +1247,11 @@ pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
= ppr target <+> text "annotated by" <+> ppr serialized
+pprExtensibleFields :: ExtensibleFields -> SDoc
+pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs
+ where
+ pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"
+
{-
*********************************************************
* *
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 8e66a67f58..91119af421 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -23,7 +23,8 @@ module MkIface (
mkIfaceExports,
coAxiomToIfaceDecl,
- tyThingToIfaceDecl -- Converting things to their Iface equivalents
+ tyThingToIfaceDecl, -- Converting things to their Iface equivalents
+ toIfaceModGuts
) where
{-
@@ -67,6 +68,7 @@ import BinFingerprint
import LoadIface
import ToIface
import FlagChecker
+import Binary
import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )
import Id
@@ -104,7 +106,6 @@ import Unique
import Util hiding ( eqListBy )
import FastString
import Maybes
-import Binary
import Fingerprint
import Exception
import UniqSet
@@ -138,25 +139,32 @@ import qualified Data.Semigroup
mkPartialIface :: HscEnv
-> ModDetails
-> ModGuts
- -> PartialModIface
+ -> IO PartialModIface
mkPartialIface hsc_env mod_details
- ModGuts{ mg_module = this_mod
- , mg_hsc_src = hsc_src
- , mg_usages = usages
- , mg_used_th = used_th
- , mg_deps = deps
- , mg_rdr_env = rdr_env
- , mg_fix_env = fix_env
- , mg_warns = warns
- , mg_hpc_info = hpc_info
- , mg_safe_haskell = safe_mode
- , mg_trust_pkg = self_trust
- , mg_doc_hdr = doc_hdr
- , mg_decl_docs = decl_docs
- , mg_arg_docs = arg_docs
- }
- = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
- safe_mode usages doc_hdr decl_docs arg_docs mod_details
+ guts@ModGuts{ mg_module = this_mod
+ , mg_hsc_src = hsc_src
+ , mg_usages = usages
+ , mg_used_th = used_th
+ , mg_deps = deps
+ , mg_rdr_env = rdr_env
+ , mg_fix_env = fix_env
+ , mg_warns = warns
+ , mg_hpc_info = hpc_info
+ , mg_safe_haskell = safe_mode
+ , mg_trust_pkg = self_trust
+ , mg_doc_hdr = doc_hdr
+ , mg_decl_docs = decl_docs
+ , mg_arg_docs = arg_docs
+ }
+ = do when (gopt Opt_Write_Phase_Core (hsc_dflags hsc_env)) $
+ registerInterfaceDataWith "ghc/phase/core" hsc_env $ \bh ->
+ -- putWithUserData (const $ return ()) bh (toIfaceModGuts guts)
+ putWithUserData (const $ return ()) bh (map toIfaceBind $ mg_binds guts)
+ ext_fs <- readIORef $ hsc_ext_fields hsc_env
+ return iface{mi_ext_fields = ext_fs}
+ where
+ iface = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
+ safe_mode usages doc_hdr decl_docs arg_docs mod_details
-- | Fully instantiate a interface
-- Adds fingerprints and potentially code generator produced information.
@@ -311,7 +319,8 @@ mkIface_ hsc_env
mi_doc_hdr = doc_hdr,
mi_decl_docs = decl_docs,
mi_arg_docs = arg_docs,
- mi_final_exts = () }
+ mi_final_exts = (),
+ mi_ext_fields = emptyExtensibleFields }
where
cmp_rule = comparing ifRuleName
-- Compare these lexicographically by OccName, *not* by unique,
@@ -2076,3 +2085,39 @@ bogusIfaceRule id_name
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
ifRuleAuto = True }
+
+--------------------------
+
+toIfaceModGuts :: ModGuts -> IfaceModGuts
+toIfaceModGuts (ModGuts f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18
+ f19 f20 f21 f22 f23 f24 f25 f26 f27 f28 f29) =
+ IfaceModGuts
+ f1
+ f2
+ f3
+ f4
+ f5
+ f6
+ f7
+ f8
+ f9
+ (map toIfaceTyCon f10)
+ (map instanceToIfaceInst f11)
+ (map famInstToIfaceFamInst f12)
+ (map patSynToIfaceDecl f13)
+ (map coreRuleToIfaceRule f14)
+ (map toIfaceBind f15)
+ f16
+ f17
+ f18
+ f19
+ f20
+ f21
+ f22
+ (map instanceToIfaceInst $ instEnvElts f23)
+ (map famInstToIfaceFamInst $ famInstEnvElts f24)
+ f25
+ f26
+ f27
+ f28
+ f29
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 077c66371e..3d9882f624 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -17,7 +17,9 @@ module TcIface (
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceAnnotations, tcIfaceCompleteSigs,
tcIfaceExpr, -- Desired by HERMIT (#7683)
- tcIfaceGlobal
+ tcIfaceGlobal,
+ tcIfaceType,
+ tcJoinInfo,
) where
#include "HsVersions.h"
View Lorry Controller Status