summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
authorKavon Farvardin <kavon@farvard.in>2018-09-23 15:29:37 -0500
committerKavon Farvardin <kavon@farvard.in>2018-09-23 15:29:37 -0500
commit84c2ad99582391005b5e873198b15e9e9eb4f78d (patch)
treecaa8c2f2ec7e97fbb4977263c6817c9af5025cf4 /compiler/iface
parent8ddb47cfcf5776e9a3c55fd37947c8a95e00fa12 (diff)
parente68b439fe5de61b9a2ca51af472185c62ccb8b46 (diff)
downloadhaskell-wip/T13904.tar.gz
update to current master againwip/T13904
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/BinFingerprint.hs2
-rw-r--r--compiler/iface/BinIface.hs74
-rw-r--r--compiler/iface/BuildTyCl.hs137
-rw-r--r--compiler/iface/FlagChecker.hs107
-rw-r--r--compiler/iface/IfaceEnv.hs88
-rw-r--r--compiler/iface/IfaceSyn.hs207
-rw-r--r--compiler/iface/IfaceType.hs948
-rw-r--r--compiler/iface/IfaceType.hs-boot13
-rw-r--r--compiler/iface/LoadIface.hs124
-rw-r--r--compiler/iface/MkIface.hs211
-rw-r--r--compiler/iface/TcIface.hs379
-rw-r--r--compiler/iface/TcIface.hs-boot5
-rw-r--r--compiler/iface/ToIface.hs168
-rw-r--r--compiler/iface/ToIface.hs-boot10
14 files changed, 1518 insertions, 955 deletions
diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs
index bbf45d7d0c..913ece0f27 100644
--- a/compiler/iface/BinFingerprint.hs
+++ b/compiler/iface/BinFingerprint.hs
@@ -10,6 +10,8 @@ module BinFingerprint
#include "HsVersions.h"
+import GhcPrelude
+
import Fingerprint
import Binary
import Name
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index f658d7f156..4e226854d6 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables #-}
+{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}
--
-- (c) The University of Glasgow 2002-2006
--
-{-# OPTIONS_GHC -O #-}
+{-# OPTIONS_GHC -O2 #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
@@ -15,11 +15,16 @@ module BinIface (
getSymtabName,
getDictFastString,
CheckHiWay(..),
- TraceBinIFaceReading(..)
+ TraceBinIFaceReading(..),
+ getWithUserData,
+ putWithUserData
+
) where
#include "HsVersions.h"
+import GhcPrelude
+
import TcRnMonad
import PrelInfo ( isKnownKeyName, lookupKnownKeyName )
import IfaceEnv
@@ -42,14 +47,18 @@ import FastString
import Constants
import Util
+import Data.Array
+import Data.Array.ST
+import Data.Array.Unsafe
import Data.Bits
import Data.Char
-import Data.List
import Data.Word
-import Data.Array
import Data.IORef
+import Data.Foldable
import Control.Monad
-
+import Control.Monad.ST
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.State.Strict as State
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
@@ -128,7 +137,14 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
wantedGot "Way" way_descr check_way
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
+ getWithUserData ncu bh
+
+-- | This performs a get action after reading the dictionary and symbol
+-- table. It is necessary to run this before trying to deserialise any
+-- Names or FastStrings.
+getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
+getWithUserData ncu bh = do
-- Read the dictionary
-- The next word in the file is a pointer to where the dictionary is
-- (probably at the end of the file)
@@ -173,6 +189,17 @@ writeBinIface dflags hi_path mod_iface = do
let way_descr = getWayDescr dflags
put_ bh way_descr
+
+ putWithUserData (debugTraceMsg dflags 3) bh mod_iface
+ -- And send the result to the file
+ writeBinMem bh hi_path
+
+-- | Put a piece of data with an initialised `UserData` field. This
+-- is necessary if you want to serialise Names or FastStrings.
+-- It also writes a symbol table and the dictionary.
+-- This segment should be read using `getWithUserData`.
+putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
+putWithUserData log_action bh payload = do
-- Remember where the dictionary pointer will go
dict_p_p <- tellBin bh
-- Placeholder for ptr to dictionary
@@ -181,8 +208,7 @@ writeBinIface dflags hi_path mod_iface = do
-- Remember where the symbol table pointer will go
symtab_p_p <- tellBin bh
put_ bh symtab_p_p
-
- -- Make some intial state
+ -- Make some initial state
symtab_next <- newFastMutInt
writeFastMutInt symtab_next 0
symtab_map <- newIORef emptyUFM
@@ -200,7 +226,7 @@ writeBinIface dflags hi_path mod_iface = do
bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
(putName bin_dict bin_symtab)
(putFastString bin_dict)
- put_ bh mod_iface
+ put_ bh payload
-- Write the symtab pointer at the front of the file
symtab_p <- tellBin bh -- This is where the symtab will start
@@ -211,13 +237,13 @@ writeBinIface dflags hi_path mod_iface = do
symtab_next <- readFastMutInt symtab_next
symtab_map <- readIORef symtab_map
putSymbolTable bh symtab_next symtab_map
- debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
+ log_action (text "writeBinIface:" <+> int symtab_next
<+> text "Names")
-- NB. write the dictionary after the symbol table, because
-- writing the symbol table may create more dictionary entries.
- -- Write the dictionary pointer at the fornt of the file
+ -- Write the dictionary pointer at the front of the file
dict_p <- tellBin bh -- This is where the dictionary will start
putAt bh dict_p_p dict_p -- Fill in the placeholder
seekBin bh dict_p -- Seek back to the end of the file
@@ -226,11 +252,10 @@ writeBinIface dflags hi_path mod_iface = do
dict_next <- readFastMutInt dict_next_ref
dict_map <- readIORef dict_map_ref
putDictionary bh dict_next dict_map
- debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
+ log_action (text "writeBinIface:" <+> int dict_next
<+> text "dict entries")
- -- And send the result to the file
- writeBinMem bh hi_path
+
-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
@@ -259,15 +284,24 @@ getSymbolTable bh ncu = do
sz <- get bh
od_names <- sequence (replicate sz (get bh))
updateNameCache ncu $ \namecache ->
- let arr = listArray (0,sz-1) names
- (namecache', names) =
- mapAccumR (fromOnDiskName arr) namecache od_names
- in (namecache', arr)
+ runST $ flip State.evalStateT namecache $ do
+ mut_arr <- lift $ newSTArray_ (0, sz-1)
+ for_ (zip [0..] od_names) $ \(i, odn) -> do
+ (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
+ lift $ writeArray mut_arr i n
+ State.put nc
+ arr <- lift $ unsafeFreeze mut_arr
+ namecache' <- State.get
+ return (namecache', arr)
+ where
+ -- This binding is required because the type of newArray_ cannot be inferred
+ newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
+ newSTArray_ = newArray_
type OnDiskName = (UnitId, ModuleName, OccName)
-fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name)
-fromOnDiskName _ nc (pid, mod_name, occ) =
+fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
+fromOnDiskName nc (pid, mod_name, occ) =
let mod = mkModule pid mod_name
cache = nsNames nc
in case lookupOrigNameCache cache mod occ of
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 76b7793859..693e2899c8 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -6,15 +6,17 @@
{-# LANGUAGE CPP #-}
module BuildTyCl (
- buildDataCon, mkDataConUnivTyVarBinders,
+ buildDataCon,
buildPatSyn,
- TcMethInfo, buildClass,
- mkNewTyConRhs, mkDataTyConRhs,
+ TcMethInfo, MethInfo, buildClass,
+ mkNewTyConRhs,
newImplicitBinder, newTyConRepName
) where
#include "HsVersions.h"
+import GhcPrelude
+
import IfaceEnv
import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
import TysWiredIn( isCTupleTyConName )
@@ -25,6 +27,7 @@ import Var
import VarSet
import BasicTypes
import Name
+import NameEnv
import MkId
import Class
import TyCon
@@ -39,19 +42,6 @@ import UniqSupply
import Util
import Outputable
-mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
-mkDataTyConRhs cons
- = DataTyCon {
- data_cons = cons,
- is_enum = not (null cons) && all is_enum_con cons
- -- See Note [Enumeration types] in TyCon
- }
- where
- is_enum_con con
- | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)
- <- dataConFullSig con
- = null ex_tvs && null eq_spec && null theta && null arg_tys
-
mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
-- ^ Monadic because it makes a Name for the coercion TyCon
@@ -70,9 +60,12 @@ mkNewTyConRhs tycon_name tycon con
where
tvs = tyConTyVars tycon
roles = tyConRoles tycon
- inst_con_ty = piResultTys (dataConUserType con) (mkTyVarTys tvs)
- rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
- -- Instantiate the data con with the
+ con_arg_ty = case dataConRepArgTys con of
+ [arg_ty] -> arg_ty
+ tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
+ rhs_ty = substTyWith (dataConUnivTyVars con)
+ (mkTyVarTys tvs) con_arg_ty
+ -- Instantiate the newtype's RHS with the
-- type variables from the tycon
-- NB: a newtype DataCon has a type that must look like
-- forall tvs. <arg-ty> -> T tvs
@@ -107,21 +100,25 @@ buildDataCon :: FamInstEnvs
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
-> [FieldLabel] -- Field labels
- -> [TyVarBinder] -- Universals
- -> [TyVarBinder] -- Existentials
+ -> [TyVar] -- Universals
+ -> [TyCoVar] -- Existentials
+ -> [TyVarBinder] -- User-written 'TyVarBinder's
-> [EqSpec] -- Equality spec
- -> ThetaType -- Does not include the "stupid theta"
+ -> KnotTied ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
- -> [Type] -> Type -- Argument and result types
- -> TyCon -- Rep tycon
+ -> [KnotTied Type] -- Arguments
+ -> KnotTied Type -- Result types
+ -> KnotTied TyCon -- Rep tycon
+ -> NameEnv ConTag -- Maps the Name of each DataCon to its
+ -- ConTag
-> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
--- c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders
-buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
- univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
+buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
+ field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
+ rep_tycon tag_map
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-- This last one takes the name of the data constructor in the source
@@ -132,10 +129,12 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
; us <- newUniqueSupply
; dflags <- getDynFlags
; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
+ tag = lookupNameEnv_NF tag_map src_name
+ -- See Note [Constructor tag allocation], fixes #14657
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
- univ_tvs ex_tvs eq_spec ctxt
- arg_tys res_ty NoRRI rep_tycon
+ univ_tvs ex_tvs user_tvbs eq_spec ctxt
+ arg_tys res_ty NoRRI rep_tycon tag
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
@@ -149,13 +148,13 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
-- the type variables mentioned in the arg_tys
-- ToDo: Or functionally dependent on?
-- This whole stupid theta thing is, well, stupid.
-mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType]
+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
mkDataConStupidTheta tycon arg_tys univ_tvs
| null stupid_theta = [] -- The common case
| otherwise = filter in_arg_tys stupid_theta
where
tc_subst = zipTvSubst (tyConTyVars tycon)
- (mkTyVarTys (binderVars univ_tvs))
+ (mkTyVarTys univ_tvs)
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
-- Start by instantiating the master copy of the
-- stupid theta, taken from the TyCon
@@ -165,69 +164,6 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
tyCoVarsOfType pred `intersectVarSet` arg_tyvars
-mkDataConUnivTyVarBinders :: [TyConBinder] -- From the TyCon
- -> [TyVarBinder] -- For the DataCon
--- See Note [Building the TyBinders for a DataCon]
-mkDataConUnivTyVarBinders tc_bndrs
- = map mk_binder tc_bndrs
- where
- mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv
- where
- vis = case tc_vis of
- AnonTCB -> Specified
- NamedTCB Required -> Specified
- NamedTCB vis -> vis
-
-{- Note [Building the TyBinders for a DataCon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A DataCon needs to keep track of the visibility of its universals and
-existentials, so that visible type application can work properly. This
-is done by storing the universal and existential TyVarBinders.
-See Note [TyVarBinders in DataCons] in DataCon.
-
-During construction of a DataCon, we often start from the TyBinders of
-the parent TyCon. For example
- data Maybe a = Nothing | Just a
-The DataCons start from the TyBinders of the parent TyCon.
-
-But the ultimate TyBinders for the DataCon are *different* than those
-of the DataCon. Here is an example:
-
- data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> *
-
-The TyCon has
-
- tyConTyVars = [ k:*, a:k->*, b:k]
- tyConTyBinders = [ Named (TvBndr (k :: *) Inferred), Anon (k->*), Anon k ]
-
-The TyBinders for App line up with App's kind, given above.
-
-But the DataCon MkApp has the type
- MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b
-
-That is, its TyBinders should be
-
- dataConUnivTyVarBinders = [ TvBndr (k:*) Inferred
- , TvBndr (a:k->*) Specified
- , TvBndr (b:k) Specified ]
-
-So we want to take the TyCon's TyBinders and the TyCon's TyVars and
-merge them, pulling
- - variable names from the TyVars
- - visibilities from the TyBinders
- - but changing Anon/Required to Specified
-
-The last part about Required->Specified comes from this:
- data T k (a:k) b = MkT (a b)
-Here k is Required in T's kind, but we don't have Required binders in
-the TyBinders for a term (see Note [No Required TyBinder in terms]
-in TyCoRep), so we change it to Specified when making MkT's TyBinders
-
-This merging operation is done by mkDataConUnivTyBinders. In contrast,
-the TyBinders passed to mkDataCon are the final TyBinders stored in the
-DataCon (mkDataCon does no further work).
--}
-
------------------------------------------------------
buildPatSyn :: Name -> Bool
-> (Id,Bool) -> Maybe (Id, Bool)
@@ -278,7 +214,8 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
------------------------------------------------------
-type TcMethInfo -- A temporary intermediate, to communicate
+type TcMethInfo = MethInfo -- this variant needs zonking
+type MethInfo -- A temporary intermediate, to communicate
-- between tcClassSigs and buildClass.
= ( Name -- Name of the class op
, Type -- Type of the class op
@@ -302,7 +239,7 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [FunDep TyVar] -- Functional dependencies
-- Super classes, associated types, method info, minimal complete def.
-- This is Nothing if the class is abstract.
- -> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)
+ -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass tycon_name binders roles fds Nothing
@@ -310,7 +247,7 @@ buildClass tycon_name binders roles fds Nothing
do { traceIf (text "buildClass")
; tc_rep_name <- newTyConRepName tycon_name
- ; let univ_bndrs = mkDataConUnivTyVarBinders binders
+ ; let univ_bndrs = tyConTyVarBinders binders
univ_tvs = binderVars univ_bndrs
tycon = mkClassTyCon tycon_name binders roles
AbstractTyCon rec_clas tc_rep_name
@@ -359,7 +296,7 @@ buildClass tycon_name binders roles fds
op_names = [op | (op,_,_) <- sig_stuff]
arg_tys = sc_theta ++ op_tys
rec_tycon = classTyCon rec_clas
- univ_bndrs = mkDataConUnivTyVarBinders binders
+ univ_bndrs = tyConTyVarBinders binders
univ_tvs = binderVars univ_bndrs
; rep_nm <- newTyConRepName datacon_name
@@ -370,13 +307,15 @@ buildClass tycon_name binders roles fds
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
- univ_bndrs
+ univ_tvs
[{- no existentials -}]
+ univ_bndrs
[{- No GADT equalities -}]
[{- No theta -}]
arg_tys
(mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
rec_tycon
+ (mkTyConTagMap rec_tycon)
; rhs <- case () of
_ | use_newtype
diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs
index fd0459d6cc..2ef369a5e9 100644
--- a/compiler/iface/FlagChecker.hs
+++ b/compiler/iface/FlagChecker.hs
@@ -4,8 +4,12 @@
-- interface file as part of the recompilation checking infrastructure.
module FlagChecker (
fingerprintDynFlags
+ , fingerprintOptFlags
+ , fingerprintHpcFlags
) where
+import GhcPrelude
+
import Binary
import BinIface ()
import DynFlags
@@ -42,8 +46,11 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
map fromEnum $ EnumSet.toList extensionFlags)
-- -I, -D and -U flags affect CPP
- cpp = (map normalise includePaths, opt_P dflags ++ picPOpts dflags)
+ cpp = ( map normalise $ flattenIncludes includePaths
-- normalise: eliminate spurious differences due to "./foo" vs "foo"
+ , picPOpts dflags
+ , opt_P_signature dflags)
+ -- See Note [Repeated -optP hashing]
-- Note [path flags and recompilation]
paths = [ hcSuf ]
@@ -51,25 +58,45 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
-- -fprof-auto etc.
prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0
- -- -O, see https://ghc.haskell.org/trac/ghc/ticket/10923
- opt = if hscTarget == HscInterpreted ||
- hscTarget == HscNothing
- then 0
- else optLevel
+ flags = (mainis, safeHs, lang, cpp, paths, prof)
+
+ in -- pprTrace "flags" (ppr flags) $
+ computeFingerprint nameio flags
+-- Fingerprint the optimisation info. We keep this separate from the rest of
+-- the flags because GHCi users (especially) may wish to ignore changes in
+-- optimisation level or optimisation flags so as to use as many pre-existing
+-- object files as they can.
+-- See Note [Ignoring some flag changes]
+fingerprintOptFlags :: DynFlags
+ -> (BinHandle -> Name -> IO ())
+ -> IO Fingerprint
+fingerprintOptFlags DynFlags{..} nameio =
+ let
+ -- See https://ghc.haskell.org/trac/ghc/ticket/10923
+ -- We used to fingerprint the optimisation level, but as Joachim
+ -- Breitner pointed out in comment 9 on that ticket, it's better
+ -- to ignore that and just look at the individual optimisation flags.
+ opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags)
+ (EnumSet.toList generalFlags)
+
+ in computeFingerprint nameio opt_flags
+
+-- Fingerprint the HPC info. We keep this separate from the rest of
+-- the flags because GHCi users (especially) may wish to use an object
+-- file compiled for HPC when not actually using HPC.
+-- See Note [Ignoring some flag changes]
+fingerprintHpcFlags :: DynFlags
+ -> (BinHandle -> Name -> IO ())
+ -> IO Fingerprint
+fingerprintHpcFlags dflags@DynFlags{..} nameio =
+ let
-- -fhpc, see https://ghc.haskell.org/trac/ghc/ticket/11798
-- hpcDir is output-only, so we should recompile if it changes
hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing
- -- -fignore-asserts, which affects how `Control.Exception.assert` works
- ignore_asserts = gopt Opt_IgnoreAsserts dflags
+ in computeFingerprint nameio hpc
- -- Nesting just to avoid ever more Binary tuple instances
- flags = (mainis, safeHs, lang, cpp, paths,
- (prof, opt, hpc, ignore_asserts))
-
- in -- pprTrace "flags" (ppr flags) $
- computeFingerprint nameio flags
{- Note [path flags and recompilation]
@@ -100,3 +127,55 @@ recompilation check; here we explain why.
The only path-related flag left is -hcsuf.
-}
+
+{- Note [Ignoring some flag changes]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Normally, --make tries to reuse only compilation products that are
+the same as those that would have been produced compiling from
+scratch. Sometimes, however, users would like to be more aggressive
+about recompilation avoidance. This is particularly likely when
+developing using GHCi (see #13604). Currently, we allow users to
+ignore optimisation changes using -fignore-optim-changes, and to
+ignore HPC option changes using -fignore-hpc-changes. If there's a
+demand for it, we could also allow changes to -fprof-auto-* flags
+(although we can't allow -prof flags to differ). The key thing about
+these options is that we can still successfully link a library or
+executable when some of its components differ in these ways.
+
+The way we accomplish this is to leave the optimization and HPC
+options out of the flag hash, hashing them separately.
+-}
+
+{- Note [Repeated -optP hashing]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We invoke fingerprintDynFlags for each compiled module to include
+the hash of relevant DynFlags in the resulting interface file.
+-optP (preprocessor) flags are part of that hash.
+-optP flags can come from multiple places:
+
+ 1. -optP flags directly passed on command line.
+ 2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof.
+ 3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file.
+
+When compiling many modules at once with many -optP command line arguments
+the work of hashing -optP flags would be repeated. This can get expensive
+and as noted on #14697 it can take 7% of time and 14% of allocations on
+a real codebase.
+
+The obvious solution is to cache the hash of -optP flags per GHC invocation.
+However, one has to be careful there, as the flags that were added in 3. way
+have to be accounted for.
+
+The current strategy is as follows:
+
+ 1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p
+ is modified. This serves dual purpose. It ensures correctness for when
+ we add per file -optP flags and lets us save work for when we don't.
+ 2. When computing the fingerprint in fingerprintDynFlags use the cached
+ value *and* fingerprint the additional implied (see 2. above) -optP flags.
+ This is relatively cheap and saves the headache of fingerprinting all
+ the -optP flags and tracking all the places that could invalidate the
+ cache.
+-}
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
index f66ebdc321..864c09ce2e 100644
--- a/compiler/iface/IfaceEnv.hs
+++ b/compiler/iface/IfaceEnv.hs
@@ -1,12 +1,12 @@
-- (c) The University of Glasgow 2002-2006
-{-# LANGUAGE CPP, RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}
module IfaceEnv (
newGlobalBinder, newInteractiveBinder,
externaliseName,
lookupIfaceTop,
- lookupOrig, lookupOrigNameCache, extendNameCache,
+ lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
@@ -16,12 +16,14 @@ module IfaceEnv (
ifaceExportNames,
-- Name-cache stuff
- allocateGlobalBinder, updNameCache,
+ allocateGlobalBinder, updNameCacheTc,
mkNameCacheUpdater, NameCacheUpdater(..),
) where
#include "HsVersions.h"
+import GhcPrelude
+
import TcRnMonad
import HscTypes
import Type
@@ -59,8 +61,7 @@ newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
-- moment when we know its Module and SrcLoc in their full glory
newGlobalBinder mod occ loc
- = do { mod `seq` occ `seq` return () -- See notes with lookupOrig
- ; name <- updNameCache $ \name_cache ->
+ = do { name <- updNameCacheTc mod occ $ \name_cache ->
allocateGlobalBinder name_cache mod occ loc
; traceIf (text "newGlobalBinder" <+>
(vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
@@ -71,7 +72,7 @@ newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
-- from the interactive context
newInteractiveBinder hsc_env occ loc
= do { let mod = icInteractiveModule (hsc_IC hsc_env)
- ; updNameCacheIO hsc_env $ \name_cache ->
+ ; updNameCacheIO hsc_env mod occ $ \name_cache ->
allocateGlobalBinder name_cache mod occ loc }
allocateGlobalBinder
@@ -128,11 +129,31 @@ newtype NameCacheUpdater
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do { hsc_env <- getTopEnv
- ; return (NCU (updNameCacheIO hsc_env)) }
+ ; let !ncRef = hsc_NC hsc_env
+ ; return (NCU (updNameCache ncRef)) }
+
+updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
+ -> TcRnIf a b c
+updNameCacheTc mod occ upd_fn = do {
+ hsc_env <- getTopEnv
+ ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }
+
+
+updNameCacheIO :: HscEnv -> Module -> OccName
+ -> (NameCache -> (NameCache, c))
+ -> IO c
+updNameCacheIO hsc_env mod occ upd_fn = do {
+
+ -- First ensure that mod and occ are evaluated
+ -- If not, chaos can ensue:
+ -- we read the name-cache
+ -- then pull on mod (say)
+ -- which does some stuff that modifies the name cache
+ -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
+
+ mod `seq` occ `seq` return ()
+ ; updNameCache (hsc_NC hsc_env) upd_fn }
-updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
-updNameCache upd_fn = do { hsc_env <- getTopEnv
- ; liftIO $ updNameCacheIO hsc_env upd_fn }
{-
************************************************************************
@@ -147,26 +168,31 @@ updNameCache upd_fn = do { hsc_env <- getTopEnv
-- and 'Module' is simply that of the 'ModIface' you are typechecking.
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig mod occ
- = do { -- First ensure that mod and occ are evaluated
- -- If not, chaos can ensue:
- -- we read the name-cache
- -- then pull on mod (say)
- -- which does some stuff that modifies the name cache
- -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
- mod `seq` occ `seq` return ()
- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
-
- ; updNameCache $ \name_cache ->
- case lookupOrigNameCache (nsNames name_cache) mod occ of {
- Just name -> (name_cache, name);
- Nothing ->
- case takeUniqFromSupply (nsUniqs name_cache) of {
- (uniq, us) ->
- let
- name = mkExternalName uniq mod occ noSrcSpan
- new_cache = extendNameCache (nsNames name_cache) mod occ name
- in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
- }}}
+ = do { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
+
+ ; updNameCacheTc mod occ $ lookupNameCache mod occ }
+
+lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
+lookupOrigIO hsc_env mod occ
+ = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ
+
+lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
+-- Lookup up the (Module,OccName) in the NameCache
+-- If you find it, return it; if not, allocate a fresh original name and extend
+-- the NameCache.
+-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
+-- If we need to explore its value we will load Foo.hi; but meanwhile all we
+-- need is a Name for it.
+lookupNameCache mod occ name_cache =
+ case lookupOrigNameCache (nsNames name_cache) mod occ of {
+ Just name -> (name_cache, name);
+ Nothing ->
+ case takeUniqFromSupply (nsUniqs name_cache) of {
+ (uniq, us) ->
+ let
+ name = mkExternalName uniq mod occ noSrcSpan
+ new_cache = extendNameCache (nsNames name_cache) mod occ name
+ in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}
externaliseName :: Module -> Name -> TcRnIf m n Name
-- Take an Internal Name and make it an External one,
@@ -176,7 +202,7 @@ externaliseName mod name
loc = nameSrcSpan name
uniq = nameUnique name
; occ `seq` return () -- c.f. seq in newGlobalBinder
- ; updNameCache $ \ ns ->
+ ; updNameCacheTc mod occ $ \ ns ->
let name' = mkExternalName uniq mod occ loc
ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
in (ns', name') }
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 60206ea076..3266c5aec1 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -41,6 +41,8 @@ module IfaceSyn (
#include "HsVersions.h"
+import GhcPrelude
+
import IfaceType
import BinFingerprint
import CoreSyn( IsOrphan, isOrphan )
@@ -62,9 +64,9 @@ import SrcLoc
import Fingerprint
import Binary
import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
-import Var( TyVarBndr(..) )
+import Var( VarBndr(..) )
import TyCon ( Role (..), Injectivity(..) )
-import Util( filterOut, filterByList )
+import Util( dropList, filterByList )
import DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Lexeme (isLexSym)
import DynFlags
@@ -85,7 +87,7 @@ infixl 3 &&&
-- | A binding top-level 'Name' in an interface file (e.g. the name of an
-- 'IfaceDecl').
type IfaceTopBndr = Name
- -- It's convenient to have an Name in the IfaceSyn, although in each
+ -- It's convenient to have a Name in the IfaceSyn, although in each
-- case the namespace is implied by the context. However, having an
-- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints
-- very convenient. Moreover, having the key of the binder means that
@@ -180,9 +182,11 @@ data IfaceClassBody
data IfaceTyConParent
= IfNoParent
- | IfDataInstance IfExtName
- IfaceTyCon
- IfaceTcArgs
+ | IfDataInstance
+ IfExtName -- Axiom name
+ IfaceTyCon -- Family TyCon (pretty-printing only, not used in TcIface)
+ -- see Note [Pretty printing via IfaceSyn] in PprTyThing
+ IfaceAppArgs -- Arguments of the family TyCon
data IfaceFamTyConFlav
= IfaceDataFamilyTyCon -- Data family
@@ -190,6 +194,7 @@ data IfaceFamTyConFlav
| IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
-- ^ Name of associated axiom and branches for pretty printing purposes,
-- or 'Nothing' for an empty closed family without an axiom
+ -- See Note [Pretty printing via IfaceSyn] in PprTyThing
| IfaceAbstractClosedSynFamilyTyCon
| IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
@@ -209,7 +214,7 @@ data IfaceAT = IfaceAT -- See Class.ClassATItem
-- This is just like CoAxBranch
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
, ifaxbCoVars :: [IfaceIdBndr]
- , ifaxbLHS :: IfaceTcArgs
+ , ifaxbLHS :: IfaceAppArgs
, ifaxbRoles :: [Role]
, ifaxbRHS :: IfaceType
, ifaxbIncomps :: [BranchIndex] }
@@ -238,7 +243,14 @@ data IfaceConDecl
-- but it's not so easy for the original TyCon/DataCon
-- So this guarantee holds for IfaceConDecl, but *not* for DataCon
- ifConExTvs :: [IfaceForAllBndr], -- Existential tyvars (w/ visibility)
+ ifConExTCvs :: [IfaceBndr], -- Existential ty/covars
+ ifConUserTvBinders :: [IfaceForAllBndr],
+ -- The tyvars, in the order the user wrote them
+ -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the
+ -- set of tyvars (*not* covars) of ifConExTCvs, unioned
+ -- with the set of ifBinders (from the parent IfaceDecl)
+ -- whose tyvars do not appear in ifConEqSpec
+ -- See Note [DataCon user type variable binders] in DataCon
ifConEqSpec :: IfaceEqSpec, -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
@@ -564,7 +576,7 @@ pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
| otherwise
= brackets (pprWithCommas (pprIfaceTvBndr True) tvs <> semi <+>
pprWithCommas pprIfaceIdBndr cvs)
- pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys)
+ pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys)
maybe_incomps = ppUnless (null incomps) $ parens $
text "incompatible indices:" <+> ppr incomps
@@ -691,26 +703,28 @@ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
-- See Note [Pretty-printing TyThings] in PprTyThing
pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
- ifCtxt = context,
+ ifCtxt = context, ifResKind = kind,
ifRoles = roles, ifCons = condecls,
ifParent = parent,
ifGadtSyntax = gadt,
ifBinders = binders })
- | gadt_style = vcat [ pp_roles
- , pp_nd <+> pp_lhs <+> pp_where
- , nest 2 (vcat pp_cons)
- , nest 2 $ ppShowIface ss pp_extra ]
- | otherwise = vcat [ pp_roles
- , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
- , nest 2 $ ppShowIface ss pp_extra ]
+ | gadt = vcat [ pp_roles
+ , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where
+ , nest 2 (vcat pp_cons)
+ , nest 2 $ ppShowIface ss pp_extra ]
+ | otherwise = vcat [ pp_roles
+ , hang (pp_nd <+> pp_lhs <+> pp_kind) 2 (add_bars pp_cons)
+ , nest 2 $ ppShowIface ss pp_extra ]
where
is_data_instance = isIfaceDataInstance parent
- gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons
cons = visibleIfConDecls condecls
- pp_where = ppWhen (gadt_style && not (null cons)) $ text "where"
+ pp_where = ppWhen (gadt && not (null cons)) $ text "where"
pp_cons = ppr_trim (map show_con cons) :: [SDoc]
+ pp_kind
+ | isIfaceLiftedTypeKind kind = empty
+ | otherwise = dcolon <+> ppr kind
pp_lhs = case parent of
IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing
@@ -732,7 +746,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc)
show_con dc
- | ok_con dc = Just $ pprIfaceConDecl ss gadt_style tycon binders parent dc
+ | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc
| otherwise = Nothing
pp_nd = case condecls of
@@ -851,11 +865,13 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name,
= sdocWithDynFlags mk_msg
where
mk_msg dflags
- = hsep [ text "pattern", pprPrefixOcc name, dcolon
- , univ_msg, pprIfaceContextArr req_ctxt
- , ppWhen insert_empty_ctxt $ parens empty <+> darrow
- , ex_msg, pprIfaceContextArr prov_ctxt
- , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]
+ = hang (text "pattern" <+> pprPrefixOcc name)
+ 2 (dcolon <+> sep [univ_msg
+ , pprIfaceContextArr req_ctxt
+ , ppWhen insert_empty_ctxt $ parens empty <+> darrow
+ , ex_msg
+ , pprIfaceContextArr prov_ctxt
+ , pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys ])
where
univ_msg = pprUserIfaceForAll univ_bndrs
ex_msg = pprUserIfaceForAll ex_bndrs
@@ -940,7 +956,7 @@ pprIfaceTyConParent IfNoParent
pprIfaceTyConParent (IfDataInstance _ tc tys)
= sdocWithDynFlags $ \dflags ->
let ftys = stripInvisArgs dflags tys
- in pprIfaceTypeApp TopPrec tc ftys
+ in pprIfaceTypeApp topPrec tc ftys
pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name
-> [IfaceTyConBinder] -- of the tycon, for invisible-suppression
@@ -953,12 +969,6 @@ pprIfaceDeclHead context ss tc_occ bndrs m_res_kind
<+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs)
, maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ]
-isVanillaIfaceConDecl :: IfaceConDecl -> Bool
-isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
- , ifConEqSpec = eq_spec
- , ifConCtxt = ctxt })
- = (null ex_tvs) && (null eq_spec) && (null ctxt)
-
pprIfaceConDecl :: ShowSub -> Bool
-> IfaceTopBndr
-> [IfaceTyConBinder]
@@ -966,37 +976,46 @@ pprIfaceConDecl :: ShowSub -> Bool
-> IfaceConDecl -> SDoc
pprIfaceConDecl ss gadt_style tycon tc_binders parent
(IfCon { ifConName = name, ifConInfix = is_infix,
- ifConExTvs = ex_tvs,
+ ifConUserTvBinders = user_tvbs,
ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
ifConStricts = stricts, ifConFields = fields })
- | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty
- | not (null fields) = pp_prefix_con <+> pp_field_args
- | is_infix
- , [ty1, ty2] <- pp_args = sep [ ty1
- , pprInfixIfDeclBndr how_much (occName name)
- , ty2]
-
- | otherwise = pp_prefix_con <+> sep pp_args
+ | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty
+ | otherwise = ppr_ex_quant pp_h98_con
where
+ pp_h98_con
+ | not (null fields) = pp_prefix_con <+> pp_field_args
+ | is_infix
+ , [ty1, ty2] <- pp_args
+ = sep [ ty1
+ , pprInfixIfDeclBndr how_much (occName name)
+ , ty2]
+ | otherwise = pp_prefix_con <+> sep pp_args
+
how_much = ss_how_much ss
tys_w_strs :: [(IfaceBang, IfaceType)]
tys_w_strs = zip stricts arg_tys
pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name)
- (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
- ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs)
- ctxt pp_tau
+ -- If we're pretty-printing a H98-style declaration with existential
+ -- quantification, then user_tvbs will always consist of the universal
+ -- tyvar binders followed by the existential tyvar binders. So to recover
+ -- the visibilities of the existential tyvar binders, we can simply drop
+ -- the universal tyvar binders from user_tvbs.
+ ex_tvbs = dropList tc_binders user_tvbs
+ ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt
+ pp_gadt_res_ty = mk_user_con_res_ty eq_spec
+ ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau
-- A bit gruesome this, but we can't form the full con_tau, and ppr it,
-- because we don't have a Name for the tycon, only an OccName
pp_tau | null fields
- = case pp_args ++ [pp_res_ty] of
+ = case pp_args ++ [pp_gadt_res_ty] of
(t:ts) -> fsep (t : map (arrow <+>) ts)
[] -> panic "pp_con_taus"
| otherwise
- = sep [pp_field_args, arrow <+> pp_res_ty]
+ = sep [pp_field_args, arrow <+> pp_gadt_res_ty]
- ppr_bang IfNoBang = sdocWithPprDebug $ \dbg -> ppWhen dbg $ char '_'
+ ppr_bang IfNoBang = whenPprDebug $ char '_'
ppr_bang IfStrict = char '!'
ppr_bang IfUnpack = text "{-# UNPACK #-}"
ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>
@@ -1030,23 +1049,24 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
sel = flSelector lbl
occ = mkVarOccFS (flLabel lbl)
- mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
+ mk_user_con_res_ty :: IfaceEqSpec -> SDoc
-- See Note [Result type of a data family GADT]
mk_user_con_res_ty eq_spec
| IfDataInstance _ tc tys <- parent
- = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
+ = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys))
| otherwise
- = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
+ = sdocWithDynFlags (ppr_tc_app gadt_subst)
where
gadt_subst = mkIfaceTySubst eq_spec
- con_univ_tvs = filterOut (inDomIfaceTySubst gadt_subst) $
- map ifTyConBinderTyVar tc_binders
ppr_tc_app gadt_subst dflags
= pprPrefixIfDeclBndr how_much (occName tycon)
<+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
- | (tv,_kind)
- <- map ifTyConBinderTyVar $
+ | IfaceTvBndr (tv,_kind)
+ -- Coercions variables are invisible, see Note
+ -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
+ -- in TyCoRep
+ <- map (ifTyConBinderVar) $
suppressIfaceInvisibles dflags tc_binders tc_binders ]
instance Outputable IfaceRule where
@@ -1082,9 +1102,6 @@ ppr_rough :: Maybe IfaceTyCon -> SDoc
ppr_rough Nothing = dot
ppr_rough (Just tc) = ppr tc
-tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr
-tv_to_forall_bndr tv = TvBndr tv Specified
-
{-
Note [Result type of a data family GADT]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1276,7 +1293,7 @@ freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i})
freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k
, ifParent = p, ifCtxt = ctxt, ifCons = cons })
- = freeNamesIfTyVarBndrs bndrs &&&
+ = freeNamesIfVarBndrs bndrs &&&
freeNamesIfType res_k &&&
freeNamesIfaceTyConParent p &&&
freeNamesIfContext ctxt &&&
@@ -1284,18 +1301,18 @@ freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k
freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k
, ifSynRhs = rhs })
- = freeNamesIfTyVarBndrs bndrs &&&
+ = freeNamesIfVarBndrs bndrs &&&
freeNamesIfKind res_k &&&
freeNamesIfType rhs
freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k
, ifFamFlav = flav })
- = freeNamesIfTyVarBndrs bndrs &&&
+ = freeNamesIfVarBndrs bndrs &&&
freeNamesIfKind res_k &&&
freeNamesIfFamFlav flav
freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body })
- = freeNamesIfTyVarBndrs bndrs &&&
+ = freeNamesIfVarBndrs bndrs &&&
freeNamesIfClassBody cls_body
freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches })
@@ -1313,8 +1330,8 @@ freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _)
, ifFieldLabels = lbls })
= unitNameSet matcher &&&
maybe emptyNameSet (unitNameSet . fst) mb_builder &&&
- freeNamesIfTyVarBndrs univ_bndrs &&&
- freeNamesIfTyVarBndrs ex_bndrs &&&
+ freeNamesIfVarBndrs univ_bndrs &&&
+ freeNamesIfVarBndrs ex_bndrs &&&
freeNamesIfContext prov_ctxt &&&
freeNamesIfContext req_ctxt &&&
fnList freeNamesIfType args &&&
@@ -1336,7 +1353,7 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
, ifaxbRHS = rhs })
= fnList freeNamesIfTvBndr tyvars &&&
fnList freeNamesIfIdBndr covars &&&
- freeNamesIfTcArgs lhs &&&
+ freeNamesIfAppArgs lhs &&&
freeNamesIfType rhs
freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
@@ -1377,12 +1394,12 @@ freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
freeNamesIfConDecls _ = emptyNameSet
freeNamesIfConDecl :: IfaceConDecl -> NameSet
-freeNamesIfConDecl (IfCon { ifConExTvs = ex_tvs, ifConCtxt = ctxt
+freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt
, ifConArgTys = arg_tys
, ifConFields = flds
, ifConEqSpec = eq_spec
, ifConStricts = bangs })
- = freeNamesIfTyVarBndrs ex_tvs &&&
+ = fnList freeNamesIfBndr ex_tvs &&&
freeNamesIfContext ctxt &&&
fnList freeNamesIfType arg_tys &&&
mkNameSet (map flSelector flds) &&&
@@ -1396,26 +1413,32 @@ freeNamesIfBang _ = emptyNameSet
freeNamesIfKind :: IfaceType -> NameSet
freeNamesIfKind = freeNamesIfType
-freeNamesIfTcArgs :: IfaceTcArgs -> NameSet
-freeNamesIfTcArgs (ITC_Vis t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts
-freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks
-freeNamesIfTcArgs ITC_Nil = emptyNameSet
+freeNamesIfAppArgs :: IfaceAppArgs -> NameSet
+freeNamesIfAppArgs (IA_Vis t ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts
+freeNamesIfAppArgs (IA_Invis k ks) = freeNamesIfKind k &&& freeNamesIfAppArgs ks
+freeNamesIfAppArgs IA_Nil = emptyNameSet
freeNamesIfType :: IfaceType -> NameSet
freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet
freeNamesIfType (IfaceTyVar _) = emptyNameSet
-freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
-freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts
-freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts
+freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t
+freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts
+freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
freeNamesIfType (IfaceLitTy _) = emptyNameSet
-freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTyVarBndr tv &&& freeNamesIfType t
+freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
+freeNamesIfMCoercion :: IfaceMCoercion -> NameSet
+freeNamesIfMCoercion IfaceMRefl = emptyNameSet
+freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co
+
freeNamesIfCoercion :: IfaceCoercion -> NameSet
-freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t
+freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t
+freeNamesIfCoercion (IfaceGReflCo _ t mco)
+ = freeNamesIfType t &&& freeNamesIfMCoercion mco
freeNamesIfCoercion (IfaceFunCo _ c1 c2)
= freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
@@ -1424,8 +1447,9 @@ freeNamesIfCoercion (IfaceAppCo c1 c2)
= freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
freeNamesIfCoercion (IfaceForAllCo _ kind_co co)
= freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
-freeNamesIfCoercion (IfaceCoVarCo _)
- = emptyNameSet
+freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet
+freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet
+freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet
freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
= unitNameSet ax &&& fnList freeNamesIfCoercion cos
freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
@@ -1440,8 +1464,6 @@ freeNamesIfCoercion (IfaceLRCo _ co)
= freeNamesIfCoercion co
freeNamesIfCoercion (IfaceInstCo co co2)
= freeNamesIfCoercion co &&& freeNamesIfCoercion co2
-freeNamesIfCoercion (IfaceCoherenceCo c1 c2)
- = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
freeNamesIfCoercion (IfaceKindCo c)
= freeNamesIfCoercion c
freeNamesIfCoercion (IfaceSubCo co)
@@ -1455,13 +1477,12 @@ freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfacePluginProv _) = emptyNameSet
-freeNamesIfProv (IfaceHoleProv _) = emptyNameSet
-freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet
-freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv
+freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet
+freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr
-freeNamesIfTyVarBndrs :: [TyVarBndr IfaceTvBndr vis] -> NameSet
-freeNamesIfTyVarBndrs = fnList freeNamesIfTyVarBndr
+freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet
+freeNamesIfVarBndrs = fnList freeNamesIfVarBndr
freeNamesIfBndr :: IfaceBndr -> NameSet
freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
@@ -1552,7 +1573,7 @@ freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
freeNamesIfaceTyConParent IfNoParent = emptyNameSet
freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
- = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys
+ = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys
-- helpers
(&&&) :: NameSet -> NameSet -> NameSet
@@ -1865,7 +1886,7 @@ instance Binary IfaceConDecls where
_ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
instance Binary IfaceConDecl where
- put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
+ put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
putIfaceTopBndr bh a1
put_ bh a2
put_ bh a3
@@ -1873,10 +1894,11 @@ instance Binary IfaceConDecl where
put_ bh a5
put_ bh a6
put_ bh a7
- put_ bh (length a8)
- mapM_ (put_ bh) a8
- put_ bh a9
+ put_ bh a8
+ put_ bh (length a9)
+ mapM_ (put_ bh) a9
put_ bh a10
+ put_ bh a11
get bh = do
a1 <- getIfaceTopBndr bh
a2 <- get bh
@@ -1885,11 +1907,12 @@ instance Binary IfaceConDecl where
a5 <- get bh
a6 <- get bh
a7 <- get bh
+ a8 <- get bh
n_fields <- get bh
- a8 <- replicateM n_fields (get bh)
- a9 <- get bh
+ a9 <- replicateM n_fields (get bh)
a10 <- get bh
- return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
+ a11 <- get bh
+ return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
instance Binary IfaceBang where
put_ bh IfNoBang = putByte bh 0
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 39e30283db..23b09dab7a 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -14,28 +14,30 @@ module IfaceType (
IfExtName, IfLclName,
IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
+ IfaceMCoercion(..),
IfaceUnivCoProv(..),
IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
- IfaceTyLit(..), IfaceTcArgs(..),
+ IfaceTyLit(..), IfaceAppArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
- ifTyConBinderTyVar, ifTyConBinderName,
+ ifForAllBndrVar, ifForAllBndrName,
+ ifTyConBinderVar, ifTyConBinderName,
-- Equality testing
isIfaceLiftedTypeKind,
- -- Conversion from IfaceTcArgs -> [IfaceType]
- tcArgsIfaceTypes,
+ -- Conversion from IfaceAppArgs -> [IfaceType]
+ appArgsIfaceTypes,
-- Printing
pprIfaceType, pprParendIfaceType, pprPrecIfaceType,
pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
- pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
- pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
- pprIfaceTyLit,
+ pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs,
+ pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll,
+ pprIfaceSigmaType, pprIfaceTyLit,
pprIfaceCoercion, pprParendIfaceCoercion,
splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
@@ -44,12 +46,16 @@ module IfaceType (
stripIfaceInvisVars,
stripInvisArgs,
- mkIfaceTySubst, substIfaceTyVar, substIfaceTcArgs, inDomIfaceTySubst
+ mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )
+import GhcPrelude
+
+import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon
+ , liftedRepDataConTyCon )
+import {-# SOURCE #-} TyCoRep ( isRuntimeRepTy )
import DynFlags
import TyCon hiding ( pprPromotionQuote )
@@ -65,7 +71,7 @@ import FastStringEnv
import Util
import Data.Maybe( isJust )
-import Data.List (foldl')
+import qualified Data.Semigroup as Semi
{-
************************************************************************
@@ -90,6 +96,13 @@ type IfaceTvBndr = (IfLclName, IfaceKind)
ifaceTvBndrName :: IfaceTvBndr -> IfLclName
ifaceTvBndrName (n,_) = n
+ifaceIdBndrName :: IfaceIdBndr -> IfLclName
+ifaceIdBndrName (n,_) = n
+
+ifaceBndrName :: IfaceBndr -> IfLclName
+ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr
+ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr
+
type IfaceLamBndr = (IfaceBndr, IfaceOneShot)
data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
@@ -108,23 +121,30 @@ data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
-------------------------------
type IfaceKind = IfaceType
-data IfaceType -- A kind of universal type, used for types and kinds
- = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
+-- | A kind of universal type, used for types and kinds.
+--
+-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType'
+-- before being printed. See Note [Pretty printing via IfaceSyn] in PprTyThing
+data IfaceType
+ = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
| IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceLitTy IfaceTyLit
- | IfaceAppTy IfaceType IfaceType
+ | IfaceAppTy IfaceType IfaceAppArgs
+ -- See Note [Suppressing invisible arguments] for
+ -- an explanation of why the second field isn't
+ -- IfaceType, analogous to AppTy.
| IfaceFunTy IfaceType IfaceType
| IfaceDFunTy IfaceType IfaceType
| IfaceForAllTy IfaceForAllBndr IfaceType
- | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated
- -- Includes newtypes, synonyms, tuples
+ | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated
+ -- Includes newtypes, synonyms, tuples
| IfaceCastTy IfaceType IfaceCoercion
| IfaceCoercionTy IfaceCoercion
| IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
TupleSort -- What sort of tuple?
IsPromoted -- A bit like IfaceTyCon
- IfaceTcArgs -- arity = length args
+ IfaceAppArgs -- arity = length args
-- For promoted data cons, the kind args are omitted
type IfacePredType = IfaceType
@@ -135,25 +155,28 @@ data IfaceTyLit
| IfaceStrTyLit FastString
deriving (Eq)
-type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis
-type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag
+type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis
+type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag
-- See Note [Suppressing invisible arguments]
-- We use a new list type (rather than [(IfaceType,Bool)], because
-- it'll be more compact and faster to parse in interface
-- files. Rather than two bytes and two decisions (nil/cons, and
-- type/kind) there'll just be one.
-data IfaceTcArgs
- = ITC_Nil
- | ITC_Vis IfaceType IfaceTcArgs -- "Vis" means show when pretty-printing
- | ITC_Invis IfaceKind IfaceTcArgs -- "Invis" means don't show when pretty-printing
+data IfaceAppArgs
+ = IA_Nil
+ | IA_Vis IfaceType IfaceAppArgs -- "Vis" means show when pretty-printing
+ | IA_Invis IfaceKind IfaceAppArgs -- "Invis" means don't show when pretty-printing
-- except with -fprint-explicit-kinds
-instance Monoid IfaceTcArgs where
- mempty = ITC_Nil
- ITC_Nil `mappend` xs = xs
- ITC_Vis ty rest `mappend` xs = ITC_Vis ty (rest `mappend` xs)
- ITC_Invis ki rest `mappend` xs = ITC_Invis ki (rest `mappend` xs)
+instance Semi.Semigroup IfaceAppArgs where
+ IA_Nil <> xs = xs
+ IA_Vis ty rest <> xs = IA_Vis ty (rest Semi.<> xs)
+ IA_Invis ki rest <> xs = IA_Invis ki (rest Semi.<> xs)
+
+instance Monoid IfaceAppArgs where
+ mempty = IA_Nil
+ mappend = (Semi.<>)
-- Encodes type constructors, kind constructors,
-- coercion constructors, the lot.
@@ -179,18 +202,20 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
| IfaceSumTyCon !Arity
-- ^ e.g. @(a | b | c)@
- | IfaceEqualityTyCon !Bool
- -- ^ a type equality. 'True' indicates kind-homogeneous.
- -- See Note [Equality predicates in IfaceType] for
- -- details.
+ | IfaceEqualityTyCon
+ -- ^ A heterogeneous equality TyCon
+ -- (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon)
+ -- that is actually being applied to two types
+ -- of the same kind. This affects pretty-printing
+ -- only: see Note [Equality predicates in IfaceType]
deriving (Eq)
{- Note [Free tyvars in IfaceType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an
-IfaceType and pretty printing that. This eliminates a lot of
-pretty-print duplication, and it matches what we do with
-pretty-printing TyThings.
+Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to
+an IfaceType and pretty printing that. This eliminates a lot of
+pretty-print duplication, and it matches what we do with pretty-
+printing TyThings. See Note [Pretty printing via IfaceSyn] in PprTyThing.
It works fine for closed types, but when printing debug traces (e.g.
when using -ddump-tc-trace) we print a lot of /open/ types. These
@@ -204,28 +229,61 @@ Note that:
to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType
and then pretty-print" pipeline.
+We do the same for covars, naturally.
Note [Equality predicates in IfaceType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC has several varieties of type equality (see Note [The equality types story]
-in TysPrim for details) which all must be rendered with different surface syntax
-during pretty-printing. Which syntax we use depends upon,
-
- 1. Which predicate tycon was used
- 2. Whether the types being compared are of the same kind.
-
-Unfortunately, determining (2) from an IfaceType isn't possible since we can't
-see through type synonyms. Consequently, we need to record whether the equality
-is homogeneous or not in IfaceTyConSort for the purposes of pretty-printing.
-
-Namely we handle these cases,
-
- Predicate Homogeneous Heterogeneous
- ---------------- ----------- -------------
- eqTyCon ~ N/A
- heqTyCon ~ ~~
- eqPrimTyCon ~# ~~
- eqReprPrimTyCon Coercible Coercible
+in TysPrim for details). In an effort to avoid confusing users, we suppress
+the differences during pretty printing unless certain flags are enabled.
+Here is how each equality predicate* is printed in homogeneous and
+heterogeneous contexts, depending on which combination of the
+-fprint-explicit-kinds and -fprint-equality-relations flags is used:
+
+---------------------------------------------------------------------------------------
+| Predicate | Neither flag | -fprint-explicit-kinds |
+|-------------------------------|----------------------------|------------------------|
+| a ~ b (homogeneous) | a ~ b | (a :: *) ~ (b :: *) |
+| a ~~ b, homogeneously | a ~ b | (a :: *) ~ (b :: *) |
+| a ~~ b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) |
+| a ~# b, homogeneously | a ~ b | (a :: *) ~ (b :: *) |
+| a ~# b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) |
+| Coercible a b (homogeneous) | Coercible a b | Coercible * a b |
+| a ~R# b, homogeneously | Coercible a b | Coercible * a b |
+| a ~R# b, heterogeneously | a ~R# b | (a :: *) ~R# (c :: k) |
+|-------------------------------|----------------------------|------------------------|
+| Predicate | -fprint-equality-relations | Both flags |
+|-------------------------------|----------------------------|------------------------|
+| a ~ b (homogeneous) | a ~ b | (a :: *) ~ (b :: *) |
+| a ~~ b, homogeneously | a ~~ b | (a :: *) ~~ (b :: *) |
+| a ~~ b, heterogeneously | a ~~ c | (a :: *) ~~ (c :: k) |
+| a ~# b, homogeneously | a ~# b | (a :: *) ~# (b :: *) |
+| a ~# b, heterogeneously | a ~# c | (a :: *) ~# (c :: k) |
+| Coercible a b (homogeneous) | Coercible a b | Coercible * a b |
+| a ~R# b, homogeneously | a ~R# b | (a :: *) ~R# (b :: *) |
+| a ~R# b, heterogeneously | a ~R# b | (a :: *) ~R# (c :: k) |
+---------------------------------------------------------------------------------------
+
+(* There is no heterogeneous, representational, lifted equality counterpart
+to (~~). There could be, but there seems to be no use for it.)
+
+This table adheres to the following rules:
+
+A. With -fprint-equality-relations, print the true equality relation.
+B. Without -fprint-equality-relations:
+ i. If the equality is representational and homogeneous, use Coercible.
+ ii. Otherwise, if the equality is representational, use ~R#.
+ iii. If the equality is nominal and homogeneous, use ~.
+ iv. Otherwise, if the equality is nominal, use ~~.
+C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator,
+ as above; or print the kind with Coercible.
+D. Without -fprint-explicit-kinds, don't print kinds.
+
+A hetero-kinded equality is used homogeneously when it is applied to two
+identical kinds. Unfortunately, determining this from an IfaceType isn't
+possible since we can't see through type synonyms. Consequently, we need to
+record whether this particular application is homogeneous in IfaceTyConSort
+for the purposes of pretty-printing.
See Note [The equality types story] in TysPrim.
-}
@@ -236,47 +294,51 @@ data IfaceTyConInfo -- Used to guide pretty-printing
, ifaceTyConSort :: IfaceTyConSort }
deriving (Eq)
+data IfaceMCoercion
+ = IfaceMRefl
+ | IfaceMCo IfaceCoercion
+
data IfaceCoercion
- = IfaceReflCo Role IfaceType
+ = IfaceReflCo IfaceType
+ | IfaceGReflCo Role IfaceType (IfaceMCoercion)
| IfaceFunCo Role IfaceCoercion IfaceCoercion
| IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
| IfaceAppCo IfaceCoercion IfaceCoercion
- | IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion
+ | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion
| IfaceCoVarCo IfLclName
| IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
+ | IfaceAxiomRuleCo IfLclName [IfaceCoercion]
+ -- There are only a fixed number of CoAxiomRules, so it suffices
+ -- to use an IfaceLclName to distinguish them.
+ -- See Note [Adding built-in type families] in TcTypeNats
| IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType
| IfaceSymCo IfaceCoercion
| IfaceTransCo IfaceCoercion IfaceCoercion
| IfaceNthCo Int IfaceCoercion
| IfaceLRCo LeftOrRight IfaceCoercion
| IfaceInstCo IfaceCoercion IfaceCoercion
- | IfaceCoherenceCo IfaceCoercion IfaceCoercion
| IfaceKindCo IfaceCoercion
| IfaceSubCo IfaceCoercion
- | IfaceAxiomRuleCo IfLclName [IfaceCoercion]
+ | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType]
+ | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion]
data IfaceUnivCoProv
= IfaceUnsafeCoerceProv
| IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
- | IfaceHoleProv Unique
- -- ^ See Note [Holes in IfaceUnivCoProv]
-{-
-Note [Holes in IfaceUnivCoProv]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When typechecking fails the typechecker will produce a HoleProv UnivCoProv to
-stand in place of the unproven assertion. While we generally don't want to let
-these unproven assertions leak into interface files, we still need to be able to
-pretty-print them as we use IfaceType's pretty-printer to render Types. For this
-reason IfaceUnivCoProv has a IfaceHoleProv constructor; however, we fails when
-asked to serialize to a IfaceHoleProv to ensure that they don't end up in an
-interface file. To avoid an import loop between IfaceType and TyCoRep we only
-keep the hole's Unique, since that is all we need to print.
--}
+{- Note [Holes in IfaceCoercion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking fails the typechecker will produce a HoleCo to stand
+in place of the unproven assertion. While we generally don't want to
+let these unproven assertions leak into interface files, we still need
+to be able to pretty-print them as we use IfaceType's pretty-printer
+to render Types. For this reason IfaceCoercion has a IfaceHoleCo
+constructor; however, we fails when asked to serialize to a
+IfaceHoleCo to ensure that they don't end up in an interface file.
+
-{-
%************************************************************************
%* *
Functions over IFaceTypes
@@ -288,18 +350,33 @@ ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool
ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key
isIfaceLiftedTypeKind :: IfaceKind -> Bool
-isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
+isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil)
= isLiftedTypeKindTyConName (ifaceTyConName tc)
isIfaceLiftedTypeKind (IfaceTyConApp tc
- (ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
+ (IA_Vis (IfaceTyConApp ptr_rep_lifted IA_Nil) IA_Nil))
= tc `ifaceTyConHasKey` tYPETyConKey
&& ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey
isIfaceLiftedTypeKind _ = False
splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
-- Mainly for printing purposes
+--
+-- Here we split nested IfaceSigmaTy properly.
+--
+-- @
+-- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b)
+-- @
+--
+-- If you called @splitIfaceSigmaTy@ on this type:
+--
+-- @
+-- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b))
+-- @
splitIfaceSigmaTy ty
- = (bndrs, theta, tau)
+ = case (bndrs, theta) of
+ ([], []) -> (bndrs, theta, tau)
+ _ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau
+ in (bndrs ++ bndrs', theta ++ theta', tau')
where
(bndrs, rho) = split_foralls ty
(theta, tau) = split_rho rho
@@ -319,22 +396,30 @@ suppressIfaceInvisibles dflags tys xs
where
suppress _ [] = []
suppress [] a = a
- suppress (k:ks) a@(_:xs)
- | isInvisibleTyConBinder k = suppress ks xs
- | otherwise = a
+ suppress (k:ks) (x:xs)
+ | isInvisibleTyConBinder k = suppress ks xs
+ | otherwise = x : suppress ks xs
stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
stripIfaceInvisVars dflags tyvars
| gopt Opt_PrintExplicitKinds dflags = tyvars
| otherwise = filterOut isInvisibleTyConBinder tyvars
--- | Extract a IfaceTvBndr from a IfaceTyConBinder
-ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
-ifTyConBinderTyVar = binderVar
+-- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'.
+ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr
+ifForAllBndrVar = binderVar
+
+-- | Extract the variable name from an 'IfaceForAllBndr'.
+ifForAllBndrName :: IfaceForAllBndr -> IfLclName
+ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab)
--- | Extract the variable name from a IfaceTyConBinder
+-- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'.
+ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr
+ifTyConBinderVar = binderVar
+
+-- | Extract the variable name from an 'IfaceTyConBinder'.
ifTyConBinderName :: IfaceTyConBinder -> IfLclName
-ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb)
+ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb)
ifTypeIsVarFree :: IfaceType -> Bool
-- Returns True if the type definitely has no variables at all
@@ -343,7 +428,7 @@ ifTypeIsVarFree ty = go ty
where
go (IfaceTyVar {}) = False
go (IfaceFreeTyVar {}) = False
- go (IfaceAppTy fun arg) = go fun && go arg
+ go (IfaceAppTy fun args) = go fun && go_args args
go (IfaceFunTy arg res) = go arg && go res
go (IfaceDFunTy arg res) = go arg && go res
go (IfaceForAllTy {}) = False
@@ -353,9 +438,9 @@ ifTypeIsVarFree ty = go ty
go (IfaceCastTy {}) = False -- Safe
go (IfaceCoercionTy {}) = False -- Safe
- go_args ITC_Nil = True
- go_args (ITC_Vis arg args) = go arg && go_args args
- go_args (ITC_Invis arg args) = go arg && go_args args
+ go_args IA_Nil = True
+ go_args (IA_Vis arg args) = go arg && go_args args
+ go_args (IA_Invis arg args) = go arg && go_args args
{- Note [Substitution on IfaceType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -380,22 +465,28 @@ substIfaceType env ty
where
go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv
go (IfaceTyVar tv) = substIfaceTyVar env tv
- go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2)
+ go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts)
go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
go ty@(IfaceLitTy {}) = ty
- go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
- go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
+ go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys)
+ go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys)
go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
- go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty)
- go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2)
+ go_mco IfaceMRefl = IfaceMRefl
+ go_mco (IfaceMCo co) = IfaceMCo $ go_co co
+
+ go_co (IfaceReflCo ty) = IfaceReflCo (go ty)
+ go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco)
+ go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2)
go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2)
go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty)
+ go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv
go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv
+ go_co (IfaceHoleCo cv) = IfaceHoleCo cv
go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)
go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)
go_co (IfaceSymCo co) = IfaceSymCo (go_co co)
@@ -403,7 +494,6 @@ substIfaceType env ty
go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co)
go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co)
go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2)
- go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2)
go_co (IfaceKindCo co) = IfaceKindCo (go_co co)
go_co (IfaceSubCo co) = IfaceSubCo (go_co co)
go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos)
@@ -414,15 +504,14 @@ substIfaceType env ty
go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
go_prov (IfacePluginProv str) = IfacePluginProv str
- go_prov (IfaceHoleProv h) = IfaceHoleProv h
-substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
-substIfaceTcArgs env args
+substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs
+substIfaceAppArgs env args
= go args
where
- go ITC_Nil = ITC_Nil
- go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys)
- go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
+ go IA_Nil = IA_Nil
+ go (IA_Vis ty tys) = IA_Vis (substIfaceType env ty) (go tys)
+ go (IA_Invis ty tys) = IA_Invis (substIfaceType env ty) (go tys)
substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
@@ -433,47 +522,96 @@ substIfaceTyVar env tv
{-
************************************************************************
* *
- Functions over IFaceTcArgs
+ Functions over IfaceAppArgs
* *
************************************************************************
-}
-stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
+stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs
stripInvisArgs dflags tys
| gopt Opt_PrintExplicitKinds dflags = tys
| otherwise = suppress_invis tys
where
suppress_invis c
= case c of
- ITC_Invis _ ts -> suppress_invis ts
- _ -> c
-
-tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
-tcArgsIfaceTypes ITC_Nil = []
-tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
-tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts
-
-ifaceVisTcArgsLength :: IfaceTcArgs -> Int
-ifaceVisTcArgsLength = go 0
+ IA_Nil -> IA_Nil
+ IA_Invis _ ts -> suppress_invis ts
+ IA_Vis t ts -> IA_Vis t $ suppress_invis ts
+ -- Keep recursing through the remainder of the arguments, as it's
+ -- possible that there are remaining invisible ones.
+ -- See the "In type declarations" section of Note [VarBndrs,
+ -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.
+
+appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType]
+appArgsIfaceTypes IA_Nil = []
+appArgsIfaceTypes (IA_Invis t ts) = t : appArgsIfaceTypes ts
+appArgsIfaceTypes (IA_Vis t ts) = t : appArgsIfaceTypes ts
+
+ifaceVisAppArgsLength :: IfaceAppArgs -> Int
+ifaceVisAppArgsLength = go 0
where
- go !n ITC_Nil = n
- go n (ITC_Vis _ rest) = go (n+1) rest
- go n (ITC_Invis _ rest) = go n rest
+ go !n IA_Nil = n
+ go n (IA_Vis _ rest) = go (n+1) rest
+ go n (IA_Invis _ rest) = go n rest
{-
Note [Suppressing invisible arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We use the IfaceTcArgs to specify which of the arguments to a type
-constructor should be displayed when pretty-printing, under
-the control of -fprint-explicit-kinds.
+We use the IfaceAppArgs data type to specify which of the arguments to a type
+should be displayed when pretty-printing, under the control of
+-fprint-explicit-kinds.
See also Type.filterOutInvisibleTypes.
For example, given
+
T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism
'Just :: forall k. k -> 'Maybe k -- Promoted
+
we want
- T * Tree Int prints as T Tree Int
- 'Just * prints as Just *
+ T * Tree Int prints as T Tree Int
+ 'Just * prints as Just *
+
+For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit,
+since the corresponding Core constructor:
+
+ data Type
+ = ...
+ | TyConApp TyCon [Type]
+
+Already puts all of its arguments into a list. So when converting a Type to an
+IfaceType (see toIfaceAppArgsX in ToIface), we simply use the kind of the TyCon
+(which is cached) to guide the process of converting the argument Types into an
+IfaceAppArgs list.
+
+We also want this behavior for IfaceAppTy, since given:
+
+ data Proxy (a :: k)
+ f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True)
+
+We want to print the return type as `Proxy (t True)` without the use of
+-fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the
+tycon case, because the corresponding Core constructor for IfaceAppTy:
+
+ data Type
+ = ...
+ | AppTy Type Type
+
+Only stores one argument at a time. Therefore, when converting an AppTy to an
+IfaceAppTy (in toIfaceTypeX in ToIface), we:
+
+1. Flatten the chain of AppTys down as much as possible
+2. Use typeKind to determine the function Type's kind
+3. Use this kind to guide the process of converting the argument Types into an
+ IfaceAppArgs list.
+
+By flattening the arguments like this, we obtain two benefits:
+
+(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as
+ we do IfaceTyApp arguments, which means that we only need to implement the
+ logic to filter out invisible arguments once.
+(b) Unlike for tycons, finding the kind of a type in general (through typeKind)
+ is not a constant-time operation, so by flattening the arguments first, we
+ decrease the number of times we have to call typeKind.
************************************************************************
* *
@@ -493,15 +631,15 @@ if_print_coercions yes no
then yes
else no
-pprIfaceInfixApp :: TyPrec -> SDoc -> SDoc -> SDoc -> SDoc
+pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc
pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2
- = maybeParen ctxt_prec TyOpPrec $
+ = maybeParen ctxt_prec opPrec $
sep [pp_ty1, pp_tc <+> pp_ty2]
-pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
+pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc
pprIfacePrefixApp ctxt_prec pp_fun pp_tys
| null pp_tys = pp_fun
- | otherwise = maybeParen ctxt_prec TyConPrec $
+ | otherwise = maybeParen ctxt_prec appPrec $
hang pp_fun 2 (sep pp_tys)
-- ----------------------------- Printing binders ------------------------------------
@@ -529,9 +667,10 @@ pprIfaceTvBndr use_parens (tv, ki)
| otherwise = id
pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
-pprIfaceTyConBinders = sep . map go
+pprIfaceTyConBinders = sep . map (go . ifTyConBinderVar)
where
- go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb)
+ go (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
+ go (IfaceTvBndr bndr) = pprIfaceTvBndr True bndr
instance Binary IfaceBndr where
put_ bh (IfaceIdBndr aa) = do
@@ -566,57 +705,58 @@ instance Outputable IfaceType where
ppr ty = pprIfaceType ty
pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc
-pprIfaceType = pprPrecIfaceType TopPrec
-pprParendIfaceType = pprPrecIfaceType TyConPrec
+pprIfaceType = pprPrecIfaceType topPrec
+pprParendIfaceType = pprPrecIfaceType appPrec
-pprPrecIfaceType :: TyPrec -> IfaceType -> SDoc
+pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc
+-- We still need `eliminateRuntimeRep`, since the `pprPrecIfaceType` maybe
+-- called from other places, besides `:type` and `:info`.
pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty
-ppr_ty :: TyPrec -> IfaceType -> SDoc
-ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reson for IfaceFreeTyVar!
+ppr_ty :: PprPrec -> IfaceType -> SDoc
+ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar!
ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType]
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
-ppr_ty _ (IfaceTupleTy i p tys) = pprTuple i p tys
+ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys
ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n
-- Function types
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
= -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
- maybeParen ctxt_prec FunPrec $
- sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)]
+ maybeParen ctxt_prec funPrec $
+ sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)]
where
ppr_fun_tail (IfaceFunTy ty1 ty2)
- = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2
+ = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2
ppr_fun_tail other_ty
= [arrow <+> pprIfaceType other_ty]
-ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
+ppr_ty ctxt_prec (IfaceAppTy t ts)
= if_print_coercions
ppr_app_ty
ppr_app_ty_no_casts
where
ppr_app_ty =
- maybeParen ctxt_prec TyConPrec
- $ ppr_ty FunPrec ty1 <+> ppr_ty TyConPrec ty2
+ sdocWithDynFlags $ \dflags ->
+ pprIfacePrefixApp ctxt_prec
+ (ppr_ty funPrec t)
+ (map (ppr_ty appPrec) (tys_wo_kinds dflags))
+
+ tys_wo_kinds dflags = appArgsIfaceTypes $ stripInvisArgs dflags ts
-- Strip any casts from the head of the application
ppr_app_ty_no_casts =
- case split_app_tys ty1 (ITC_Vis ty2 ITC_Nil) of
- (IfaceCastTy head _, args) -> ppr_ty ctxt_prec (mk_app_tys head args)
- _ -> ppr_app_ty
-
- split_app_tys :: IfaceType -> IfaceTcArgs -> (IfaceType, IfaceTcArgs)
- split_app_tys (IfaceAppTy t1 t2) args = split_app_tys t1 (t2 `ITC_Vis` args)
- split_app_tys head args = (head, args)
+ case t of
+ IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts)
+ _ -> ppr_app_ty
- mk_app_tys :: IfaceType -> IfaceTcArgs -> IfaceType
+ mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType
mk_app_tys (IfaceTyConApp tc tys1) tys2 =
IfaceTyConApp tc (tys1 `mappend` tys2)
- mk_app_tys t1 tys2 =
- foldl' IfaceAppTy t1 (tcArgsIfaceTypes tys2)
+ mk_app_tys t1 tys2 = IfaceAppTy t1 tys2
ppr_ty ctxt_prec (IfaceCastTy ty co)
= if_print_coercions
- (parens (ppr_ty TopPrec ty <+> text "|>" <+> ppr co))
+ (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co))
(ppr_ty ctxt_prec ty)
ppr_ty ctxt_prec (IfaceCoercionTy co)
@@ -624,8 +764,8 @@ ppr_ty ctxt_prec (IfaceCoercionTy co)
(ppr_co ctxt_prec co)
(text "<>")
-ppr_ty ctxt_prec ty
- = maybeParen ctxt_prec FunPrec (pprIfaceSigmaType ShowForAllMust ty)
+ppr_ty ctxt_prec ty -- IfaceForAllTy
+ = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty)
{-
Note [Defaulting RuntimeRep variables]
@@ -649,7 +789,7 @@ overhead.
For this reason it was decided that we would hide RuntimeRep variables for now
(see #11549). We do this by defaulting all type variables of kind RuntimeRep to
-PtrLiftedRep. This is done in a pass right before pretty-printing
+LiftedRep. This is done in a pass right before pretty-printing
(defaultRuntimeRepVars, controlled by -fprint-explicit-runtime-reps)
-}
@@ -668,30 +808,44 @@ PtrLiftedRep. This is done in a pass right before pretty-printing
-- syntactic overhead in otherwise simple type signatures (e.g. ($)). See
-- Note [Defaulting RuntimeRep variables] and #11549 for further discussion.
--
-defaultRuntimeRepVars :: IfaceType -> IfaceType
-defaultRuntimeRepVars = go emptyFsEnv
+defaultRuntimeRepVars :: PprStyle -> IfaceType -> IfaceType
+defaultRuntimeRepVars sty = go emptyFsEnv
where
go :: FastStringEnv () -> IfaceType -> IfaceType
- go subs (IfaceForAllTy bndr ty)
+ go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)
| isRuntimeRep var_kind
+ , isInvisibleArgFlag argf -- don't default *visible* quantification
+ -- or we get the mess in #13963
= let subs' = extendFsEnv subs var ()
in go subs' ty
- | otherwise
- = IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr))
- (go subs ty)
- where
- var :: IfLclName
- (var, var_kind) = binderVar bndr
- go subs (IfaceTyVar tv)
+ go subs (IfaceForAllTy bndr ty)
+ = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty)
+
+ go subs ty@(IfaceTyVar tv)
| tv `elemFsEnv` subs
- = IfaceTyConApp liftedRep ITC_Nil
+ = IfaceTyConApp liftedRep IA_Nil
+ | otherwise
+ = ty
+
+ go _ ty@(IfaceFreeTyVar tv)
+ | userStyle sty && TyCoRep.isRuntimeRepTy (tyVarKind tv)
+ -- don't require -fprint-explicit-runtime-reps for good debugging output
+ = IfaceTyConApp liftedRep IA_Nil
+ | otherwise
+ = ty
+
+ go subs (IfaceTyConApp tc tc_args)
+ = IfaceTyConApp tc (go_args subs tc_args)
- go subs (IfaceFunTy kind ty)
- = IfaceFunTy (go subs kind) (go subs ty)
+ go subs (IfaceTupleTy sort is_prom tc_args)
+ = IfaceTupleTy sort is_prom (go_args subs tc_args)
- go subs (IfaceAppTy x y)
- = IfaceAppTy (go subs x) (go subs y)
+ go subs (IfaceFunTy arg res)
+ = IfaceFunTy (go subs arg) (go subs res)
+
+ go subs (IfaceAppTy t ts)
+ = IfaceAppTy (go subs t) (go_args subs ts)
go subs (IfaceDFunTy x y)
= IfaceDFunTy (go subs x) (go subs y)
@@ -699,7 +853,19 @@ defaultRuntimeRepVars = go emptyFsEnv
go subs (IfaceCastTy x co)
= IfaceCastTy (go subs x) co
- go _ other = other
+ go _ ty@(IfaceLitTy {}) = ty
+ go _ ty@(IfaceCoercionTy {}) = ty
+
+ go_ifacebndr :: FastStringEnv () -> IfaceForAllBndr -> IfaceForAllBndr
+ go_ifacebndr subs (Bndr (IfaceIdBndr (n, t)) argf)
+ = Bndr (IfaceIdBndr (n, go subs t)) argf
+ go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf)
+ = Bndr (IfaceTvBndr (n, go subs t)) argf
+
+ go_args :: FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs
+ go_args _ IA_Nil = IA_Nil
+ go_args subs (IA_Vis ty args) = IA_Vis (go subs ty) (go_args subs args)
+ go_args subs (IA_Invis ty args) = IA_Invis (go subs ty) (go_args subs args)
liftedRep :: IfaceTyCon
liftedRep =
@@ -715,28 +881,37 @@ eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc
eliminateRuntimeRep f ty = sdocWithDynFlags $ \dflags ->
if gopt Opt_PrintExplicitRuntimeReps dflags
then f ty
- else f (defaultRuntimeRepVars ty)
+ else getPprStyle $ \sty -> f (defaultRuntimeRepVars sty ty)
-instance Outputable IfaceTcArgs where
- ppr tca = pprIfaceTcArgs tca
+instance Outputable IfaceAppArgs where
+ ppr tca = pprIfaceAppArgs tca
-pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
-pprIfaceTcArgs = ppr_tc_args TopPrec
-pprParendIfaceTcArgs = ppr_tc_args TyConPrec
+pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc
+pprIfaceAppArgs = ppr_app_args topPrec
+pprParendIfaceAppArgs = ppr_app_args appPrec
-ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc
-ppr_tc_args ctx_prec args
- = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
+ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc
+ppr_app_args ctx_prec args
+ = let ppr_rest = ppr_app_args ctx_prec
+ pprTys t ts = ppr_ty ctx_prec t <+> ppr_rest ts
in case args of
- ITC_Nil -> empty
- ITC_Vis t ts -> pprTys t ts
- ITC_Invis t ts -> pprTys t ts
+ IA_Nil -> empty
+ IA_Vis t ts -> pprTys t ts
+ IA_Invis t ts -> sdocWithDynFlags $ \dflags ->
+ if gopt Opt_PrintExplicitKinds dflags
+ then pprTys t ts
+ else ppr_rest ts
-------------------
pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
pprIfaceForAllPart tvs ctxt sdoc
= ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc
+-- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@.
+pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
+pprIfaceForAllPartMust tvs ctxt sdoc
+ = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc
+
pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc
pprIfaceForAllCoPart tvs sdoc
= sep [ pprIfaceForAllCo tvs, sdoc ]
@@ -753,7 +928,7 @@ ppr_iface_forall_part show_forall tvs ctxt sdoc
-- | Render the "forall ... ." or "forall ... ->" bit of a type.
pprIfaceForAll :: [IfaceForAllBndr] -> SDoc
pprIfaceForAll [] = empty
-pprIfaceForAll bndrs@(TvBndr _ vis : _)
+pprIfaceForAll bndrs@(Bndr _ vis : _)
= add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs'
where
(bndrs', doc) = ppr_itv_bndrs bndrs vis
@@ -769,7 +944,7 @@ pprIfaceForAll bndrs@(TvBndr _ vis : _)
ppr_itv_bndrs :: [IfaceForAllBndr]
-> ArgFlag -- ^ visibility of the first binder in the list
-> ([IfaceForAllBndr], SDoc)
-ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1
+ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1
| vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
(bndrs', pprIfaceForAllBndr bndr <+> doc)
| otherwise = (all_bndrs, empty)
@@ -783,11 +958,13 @@ pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
-pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags ->
- if gopt Opt_PrintExplicitForalls dflags
- then braces $ pprIfaceTvBndr False tv
- else pprIfaceTvBndr True tv
-pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr True tv
+pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) Inferred)
+ = sdocWithDynFlags $ \dflags ->
+ if gopt Opt_PrintExplicitForalls dflags
+ then braces $ pprIfaceTvBndr False tv
+ else pprIfaceTvBndr True tv
+pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) _) = pprIfaceTvBndr True tv
+pprIfaceForAllBndr (Bndr (IfaceIdBndr idv) _) = pprIfaceIdBndr idv
pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
pprIfaceForAllCoBndr (tv, kind_co)
@@ -802,102 +979,158 @@ data ShowForAllFlag = ShowForAllMust | ShowForAllWhen
pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc
pprIfaceSigmaType show_forall ty
- = ppr_iface_forall_part show_forall tvs theta (ppr tau)
+ = eliminateRuntimeRep ppr_fn ty
where
- (tvs, theta, tau) = splitIfaceSigmaTy ty
+ ppr_fn iface_ty =
+ let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty
+ in ppr_iface_forall_part show_forall tvs theta (ppr tau)
pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
pprUserIfaceForAll tvs
= sdocWithDynFlags $ \dflags ->
- ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $
+ -- See Note [When to print foralls]
+ ppWhen (any tv_has_kind_var tvs
+ || any tv_is_required tvs
+ || gopt Opt_PrintExplicitForalls dflags) $
pprIfaceForAll tvs
where
- tv_has_kind_var (TvBndr (_,kind) _) = not (ifTypeIsVarFree kind)
+ tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _)
+ = not (ifTypeIsVarFree kind)
+ tv_has_kind_var _ = False
+
+ tv_is_required = isVisibleArgFlag . binderArgFlag
+
+{-
+Note [When to print foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We opt to explicitly pretty-print `forall`s if any of the following
+criteria are met:
+
+1. -fprint-explicit-foralls is on.
+2. A bound type variable has a polymorphic kind. E.g.,
+
+ forall k (a::k). Proxy a -> Proxy a
+
+ Since a's kind mentions a variable k, we print the foralls.
+
+3. A bound type variable is a visible argument (#14238).
+ Suppose we are printing the kind of:
+
+ T :: forall k -> k -> Type
+
+ The "forall k ->" notation means that this kind argument is required.
+ That is, it must be supplied at uses of T. E.g.,
+
+ f :: T (Type->Type) Monad -> Int
+
+ So we print an explicit "T :: forall k -> k -> Type",
+ because omitting it and printing "T :: k -> Type" would be
+ utterly misleading.
+
+ See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
+ in TyCoRep.
+
+N.B. Until now (Aug 2018) we didn't check anything for coercion variables.
+-}
-------------------
+-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'.
+pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc
+pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _)
+ = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of
+ IsPromoted -> (space <>)
+ _ -> id
+pprSpaceIfPromotedTyCon _
+ = id
+
-- See equivalent function in TyCoRep.hs
-pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc
+pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
-- Given a type-level list (t1 ': t2), see if we can print
-- it in list notation [t1, ...].
-- Precondition: Opt_PrintExplicitKinds is off
pprIfaceTyList ctxt_prec ty1 ty2
= case gather ty2 of
(arg_tys, Nothing)
- -> char '\'' <> brackets (fsep (punctuate comma
- (map (ppr_ty TopPrec) (ty1:arg_tys))))
+ -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep
+ (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys)))))
(arg_tys, Just tl)
- -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1)
- 2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]])
+ -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1)
+ 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]])
where
gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
-- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
-- = (tys, Just tl) means ty is of form t1:t2:...tn:tl
gather (IfaceTyConApp tc tys)
| tc `ifaceTyConHasKey` consDataConKey
- , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
+ , (IA_Invis _ (IA_Vis ty1 (IA_Vis ty2 IA_Nil))) <- tys
, (args, tl) <- gather ty2
= (ty1:args, tl)
| tc `ifaceTyConHasKey` nilDataConKey
= ([], Nothing)
gather ty = ([], Just ty)
-pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
+pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
-pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
+pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprTyTcApp ctxt_prec tc tys =
sdocWithDynFlags $ \dflags ->
getPprStyle $ \style ->
pprTyTcApp' ctxt_prec tc tys dflags style
-pprTyTcApp' :: TyPrec -> IfaceTyCon -> IfaceTcArgs
+pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs
-> DynFlags -> PprStyle -> SDoc
pprTyTcApp' ctxt_prec tc tys dflags style
| ifaceTyConName tc `hasKey` ipClassKey
- , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
- = maybeParen ctxt_prec FunPrec
- $ char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty
+ , IA_Vis (IfaceLitTy (IfaceStrTyLit n)) (IA_Vis ty IA_Nil) <- tys
+ = maybeParen ctxt_prec funPrec
+ $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
| IfaceTupleTyCon arity sort <- ifaceTyConSort info
, not (debugStyle style)
- , arity == ifaceVisTcArgsLength tys
- = pprTuple sort (ifaceTyConIsPromoted info) tys
+ , arity == ifaceVisAppArgsLength tys
+ = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys
| IfaceSumTyCon arity <- ifaceTyConSort info
= pprSum arity (ifaceTyConIsPromoted info) tys
| tc `ifaceTyConHasKey` consDataConKey
, not (gopt Opt_PrintExplicitKinds dflags)
- , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
+ , IA_Invis _ (IA_Vis ty1 (IA_Vis ty2 IA_Nil)) <- tys
= pprIfaceTyList ctxt_prec ty1 ty2
| tc `ifaceTyConHasKey` tYPETyConKey
- , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
+ , IA_Vis (IfaceTyConApp rep IA_Nil) IA_Nil <- tys
, rep `ifaceTyConHasKey` liftedRepDataConKey
- = kindStar
+ = kindType
| otherwise
- = sdocWithPprDebug $ \dbg ->
+ = getPprDebug $ \dbg ->
if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
-- Suppress detail unles you _really_ want to see
-> text "(TypeError ...)"
- | Just doc <- ppr_equality ctxt_prec tc (tcArgsIfaceTypes tys)
+ | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys)
-> doc
| otherwise
-> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
where
info = ifaceTyConInfo tc
- tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
+ tys_wo_kinds = appArgsIfaceTypes $ stripInvisArgs dflags tys
-- | Pretty-print a type-level equality.
+-- Returns (Just doc) if the argument is a /saturated/ application
+-- of eqTyCon (~)
+-- eqPrimTyCon (~#)
+-- eqReprPrimTyCon (~R#)
+-- heqTyCon (~~)
--
-- See Note [Equality predicates in IfaceType]
-- and Note [The equality types story] in TysPrim
-ppr_equality :: TyPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
+ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
ppr_equality ctxt_prec tc args
| hetero_eq_tc
, [k1, k2, t1, t2] <- args
@@ -910,94 +1143,119 @@ ppr_equality ctxt_prec tc args
| otherwise
= Nothing
where
- homogeneous = case ifaceTyConSort $ ifaceTyConInfo tc of
- IfaceEqualityTyCon hom -> hom
- _other -> pprPanic "ppr_equality: homogeneity" (ppr tc)
+ homogeneous = tc_name `hasKey` eqTyConKey -- (~)
+ || hetero_tc_used_homogeneously
+ where
+ hetero_tc_used_homogeneously
+ = case ifaceTyConSort $ ifaceTyConInfo tc of
+ IfaceEqualityTyCon -> True
+ _other -> False
+ -- True <=> a heterogeneous equality whose arguments
+ -- are (in this case) of the same kind
+
tc_name = ifaceTyConName tc
pp = ppr_ty
hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~)
hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#)
|| tc_name `hasKey` eqReprPrimTyConKey -- (~R#)
|| tc_name `hasKey` heqTyConKey -- (~~)
+ nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~)
+ || tc_name `hasKey` eqPrimTyConKey -- (~#)
print_equality args =
sdocWithDynFlags $ \dflags ->
getPprStyle $ \style ->
print_equality' args style dflags
print_equality' (ki1, ki2, ty1, ty2) style dflags
- | print_eqs
+ | -- If -fprint-equality-relations is on, just print the original TyCon
+ print_eqs
= ppr_infix_eq (ppr tc)
- | hetero_eq_tc
- , print_kinds || not homogeneous
- = ppr_infix_eq (text "~~")
+ | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2)
+ -- or unlifted equality (ty1 ~# ty2)
+ nominal_eq_tc, homogeneous
+ = ppr_infix_eq (text "~")
+
+ | -- Heterogeneous use of unlifted equality (ty1 ~# ty2)
+ not homogeneous
+ = ppr_infix_eq (ppr heqTyCon)
+ | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2)
+ tc_name `hasKey` eqReprPrimTyConKey, homogeneous
+ = let ki | print_kinds = [pp appPrec ki1]
+ | otherwise = []
+ in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon)
+ (ki ++ [pp appPrec ty1, pp appPrec ty2])
+
+ -- The other cases work as you'd expect
| otherwise
- = if tc_name `hasKey` eqReprPrimTyConKey
- then pprIfacePrefixApp ctxt_prec (text "Coercible")
- [pp TyConPrec ty1, pp TyConPrec ty2]
- else pprIfaceInfixApp ctxt_prec (char '~')
- (pp TyOpPrec ty1) (pp TyOpPrec ty2)
+ = ppr_infix_eq (ppr tc)
where
- ppr_infix_eq eq_op
- = pprIfaceInfixApp ctxt_prec eq_op
- (parens (pp TopPrec ty1 <+> dcolon <+> pp TyOpPrec ki1))
- (parens (pp TopPrec ty2 <+> dcolon <+> pp TyOpPrec ki2))
+ ppr_infix_eq :: SDoc -> SDoc
+ ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op
+ (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2)
+ where
+ pp_ty_ki ty ki
+ | print_kinds
+ = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki)
+ | otherwise
+ = pp opPrec ty
print_kinds = gopt Opt_PrintExplicitKinds dflags
print_eqs = gopt Opt_PrintEqualityRelations dflags ||
dumpStyle style || debugStyle style
-pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
+pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
-ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc
+ppr_iface_tc_app :: (PprPrec -> a -> SDoc) -> PprPrec -> IfaceTyCon -> [a] -> SDoc
ppr_iface_tc_app pp _ tc [ty]
- | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty)
- | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
+ | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty)
ppr_iface_tc_app pp ctxt_prec tc tys
- | tc `ifaceTyConHasKey` starKindTyConKey
- || tc `ifaceTyConHasKey` liftedTypeKindTyConKey
- || tc `ifaceTyConHasKey` unicodeStarKindTyConKey
- = kindStar -- Handle unicode; do not wrap * in parens
+ | tc `ifaceTyConHasKey` liftedTypeKindTyConKey
+ = kindType
| not (isSymOcc (nameOccName (ifaceTyConName tc)))
- = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
+ = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
| [ty1,ty2] <- tys -- Infix, two arguments;
-- we know nothing of precedence though
= pprIfaceInfixApp ctxt_prec (ppr tc)
- (pp TyOpPrec ty1) (pp TyOpPrec ty2)
+ (pp opPrec ty1) (pp opPrec ty2)
| otherwise
- = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
+ = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
-pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc
+pprSum :: Arity -> IsPromoted -> IfaceAppArgs -> SDoc
pprSum _arity is_promoted args
= -- drop the RuntimeRep vars.
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
- let tys = tcArgsIfaceTypes args
+ let tys = appArgsIfaceTypes args
args' = drop (length tys `div` 2) tys
in pprPromotionQuoteI is_promoted
- <> sumParens (pprWithBars (ppr_ty TopPrec) args')
+ <> sumParens (pprWithBars (ppr_ty topPrec) args')
-pprTuple :: TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc
-pprTuple ConstraintTuple IsNotPromoted ITC_Nil
- = text "() :: Constraint"
+pprTuple :: PprPrec -> TupleSort -> IsPromoted -> IfaceAppArgs -> SDoc
+pprTuple ctxt_prec ConstraintTuple IsNotPromoted IA_Nil
+ = maybeParen ctxt_prec appPrec $
+ text "() :: Constraint"
-- All promoted constructors have kind arguments
-pprTuple sort IsPromoted args
- = let tys = tcArgsIfaceTypes args
+pprTuple _ sort IsPromoted args
+ = let tys = appArgsIfaceTypes args
args' = drop (length tys `div` 2) tys
+ spaceIfPromoted = case args' of
+ arg0:_ -> pprSpaceIfPromotedTyCon arg0
+ _ -> id
in pprPromotionQuoteI IsPromoted <>
- tupleParens sort (pprWithCommas pprIfaceType args')
+ tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args'))
-pprTuple sort promoted args
+pprTuple _ sort promoted args
= -- drop the RuntimeRep vars.
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
- let tys = tcArgsIfaceTypes args
+ let tys = appArgsIfaceTypes args
args' = case sort of
UnboxedTuple -> drop (length tys `div` 2) tys
_ -> tys
@@ -1010,76 +1268,84 @@ pprIfaceTyLit (IfaceNumTyLit n) = integer n
pprIfaceTyLit (IfaceStrTyLit n) = text (show n)
pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
-pprIfaceCoercion = ppr_co TopPrec
-pprParendIfaceCoercion = ppr_co TyConPrec
-
-ppr_co :: TyPrec -> IfaceCoercion -> SDoc
-ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
+pprIfaceCoercion = ppr_co topPrec
+pprParendIfaceCoercion = ppr_co appPrec
+
+ppr_co :: PprPrec -> IfaceCoercion -> SDoc
+ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal
+ppr_co _ (IfaceGReflCo r ty IfaceMRefl)
+ = angleBrackets (ppr ty) <> ppr_role r
+ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co))
+ = ppr_special_co ctxt_prec
+ (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co]
ppr_co ctxt_prec (IfaceFunCo r co1 co2)
- = maybeParen ctxt_prec FunPrec $
- sep (ppr_co FunPrec co1 : ppr_fun_tail co2)
+ = maybeParen ctxt_prec funPrec $
+ sep (ppr_co funPrec co1 : ppr_fun_tail co2)
where
ppr_fun_tail (IfaceFunCo r co1 co2)
- = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2
+ = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2
ppr_fun_tail other_co
= [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
ppr_co _ (IfaceTyConAppCo r tc cos)
- = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r
+ = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
ppr_co ctxt_prec (IfaceAppCo co1 co2)
- = maybeParen ctxt_prec TyConPrec $
- ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
+ = maybeParen ctxt_prec appPrec $
+ ppr_co funPrec co1 <+> pprParendIfaceCoercion co2
ppr_co ctxt_prec co@(IfaceForAllCo {})
- = maybeParen ctxt_prec FunPrec $
+ = maybeParen ctxt_prec funPrec $
pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)
where
(tvs, inner_co) = split_co co
- split_co (IfaceForAllCo (name, _) kind_co co')
+ split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co')
+ = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
+ split_co (IfaceForAllCo (IfaceIdBndr (name, _)) kind_co co')
= let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
split_co co' = ([], co')
-ppr_co _ (IfaceCoVarCo covar) = ppr covar
+-- Why these three? See Note [TcTyVars in IfaceType]
+ppr_co _ (IfaceFreeCoVar covar) = ppr covar
+ppr_co _ (IfaceCoVarCo covar) = ppr covar
+ppr_co _ (IfaceHoleCo covar) = braces (ppr covar)
ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
- = maybeParen ctxt_prec TyConPrec $
+ = maybeParen ctxt_prec appPrec $
text "UnsafeCo" <+> ppr r <+>
pprParendIfaceType ty1 <+> pprParendIfaceType ty2
-ppr_co _ctxt_prec (IfaceUnivCo (IfaceHoleProv u) _ _ _)
- = braces $ ppr u
-
-ppr_co _ (IfaceUnivCo _ _ ty1 ty2)
- = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 )
+ppr_co _ (IfaceUnivCo prov role ty1 ty2)
+ = text "Univ" <> (parens $
+ sep [ ppr role <+> pprIfaceUnivCoProv prov
+ , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ])
ppr_co ctxt_prec (IfaceInstCo co ty)
- = maybeParen ctxt_prec TyConPrec $
+ = maybeParen ctxt_prec appPrec $
text "Inst" <+> pprParendIfaceCoercion co
<+> pprParendIfaceCoercion ty
ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
- = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos)
+ = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos)
ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)
= ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos
ppr_co ctxt_prec (IfaceSymCo co)
= ppr_special_co ctxt_prec (text "Sym") [co]
ppr_co ctxt_prec (IfaceTransCo co1 co2)
- = ppr_special_co ctxt_prec (text "Trans") [co1,co2]
+ = maybeParen ctxt_prec opPrec $
+ ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2
ppr_co ctxt_prec (IfaceNthCo d co)
= ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]
ppr_co ctxt_prec (IfaceLRCo lr co)
= ppr_special_co ctxt_prec (ppr lr) [co]
ppr_co ctxt_prec (IfaceSubCo co)
= ppr_special_co ctxt_prec (text "Sub") [co]
-ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
- = ppr_special_co ctxt_prec (text "Coh") [co1,co2]
ppr_co ctxt_prec (IfaceKindCo co)
= ppr_special_co ctxt_prec (text "Kind") [co]
-ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
+ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc
ppr_special_co ctxt_prec doc cos
- = maybeParen ctxt_prec TyConPrec
+ = maybeParen ctxt_prec appPrec
(sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
ppr_role :: Role -> SDoc
@@ -1089,6 +1355,17 @@ ppr_role r = underscore <> pp_role
Representational -> char 'R'
Phantom -> char 'P'
+------------------
+pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
+pprIfaceUnivCoProv IfaceUnsafeCoerceProv
+ = text "unsafe"
+pprIfaceUnivCoProv (IfacePhantomProv co)
+ = text "phantom" <+> pprParendIfaceCoercion co
+pprIfaceUnivCoProv (IfaceProofIrrelProv co)
+ = text "irrel" <+> pprParendIfaceCoercion co
+pprIfaceUnivCoProv (IfacePluginProv s)
+ = text "plugin" <+> doubleQuotes (text s)
+
-------------------
instance Outputable IfaceTyCon where
ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
@@ -1126,9 +1403,7 @@ instance Binary IfaceTyConSort where
put_ bh IfaceNormalTyCon = putByte bh 0
put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity
- put_ bh (IfaceEqualityTyCon hom)
- | hom = putByte bh 3
- | otherwise = putByte bh 4
+ put_ bh IfaceEqualityTyCon = putByte bh 3
get bh = do
n <- getByte bh
@@ -1136,9 +1411,7 @@ instance Binary IfaceTyConSort where
0 -> return IfaceNormalTyCon
1 -> IfaceTupleTyCon <$> get bh <*> get bh
2 -> IfaceSumTyCon <$> get bh
- 3 -> return $ IfaceEqualityTyCon True
- 4 -> return $ IfaceEqualityTyCon False
- _ -> fail "Binary(IfaceTyConSort): fail"
+ _ -> return IfaceEqualityTyCon
instance Binary IfaceTyConInfo where
put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s
@@ -1161,12 +1434,12 @@ instance Binary IfaceTyLit where
; return (IfaceStrTyLit n) }
_ -> panic ("get IfaceTyLit " ++ show tag)
-instance Binary IfaceTcArgs where
+instance Binary IfaceAppArgs where
put_ bh tk =
case tk of
- ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
- ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
- ITC_Nil -> putByte bh 2
+ IA_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
+ IA_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
+ IA_Nil -> putByte bh 2
get bh =
do c <- getByte bh
@@ -1174,13 +1447,13 @@ instance Binary IfaceTcArgs where
0 -> do
t <- get bh
ts <- get bh
- return $! ITC_Vis t ts
+ return $! IA_Vis t ts
1 -> do
t <- get bh
ts <- get bh
- return $! ITC_Invis t ts
- 2 -> return ITC_Nil
- _ -> panic ("get IfaceTcArgs " ++ show c)
+ return $! IA_Invis t ts
+ 2 -> return IA_Nil
+ _ -> panic ("get IfaceAppArgs " ++ show c)
-------------------
@@ -1188,7 +1461,7 @@ instance Binary IfaceTcArgs where
--
-- In the event that we are printing a singleton context (e.g. @Eq a@) we can
-- omit parentheses. However, we must take care to set the precedence correctly
--- to TyOpPrec, since something like @a :~: b@ must be parenthesized (see
+-- to opPrec, since something like @a :~: b@ must be parenthesized (see
-- #9658).
--
-- When printing a larger context we use 'fsep' instead of 'sep' so that
@@ -1217,16 +1490,16 @@ instance Binary IfaceTcArgs where
-- | Prints "(C a, D b) =>", including the arrow.
-- Used when we want to print a context in a type, so we
--- use FunPrec to decide whether to parenthesise a singleton
+-- use 'funPrec' to decide whether to parenthesise a singleton
-- predicate; e.g. Num a => a -> a
pprIfaceContextArr :: [IfacePredType] -> SDoc
pprIfaceContextArr [] = empty
-pprIfaceContextArr [pred] = ppr_ty FunPrec pred <+> darrow
+pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow
pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow
-- | Prints a context or @()@ if empty
-- You give it the context precedence
-pprIfaceContext :: TyPrec -> [IfacePredType] -> SDoc
+pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc
pprIfaceContext _ [] = text "()"
pprIfaceContext prec [pred] = ppr_ty prec pred
pprIfaceContext _ preds = ppr_parend_preds preds
@@ -1297,64 +1570,79 @@ instance Binary IfaceType where
_ -> do n <- get bh
return (IfaceLitTy n)
+instance Binary IfaceMCoercion where
+ put_ bh IfaceMRefl = do
+ putByte bh 1
+ put_ bh (IfaceMCo co) = do
+ putByte bh 2
+ put_ bh co
+
+ get bh = do
+ tag <- getByte bh
+ case tag of
+ 1 -> return IfaceMRefl
+ 2 -> do a <- get bh
+ return $ IfaceMCo a
+ _ -> panic ("get IfaceMCoercion " ++ show tag)
+
instance Binary IfaceCoercion where
- put_ bh (IfaceReflCo a b) = do
+ put_ bh (IfaceReflCo a) = do
putByte bh 1
put_ bh a
+ put_ bh (IfaceGReflCo a b c) = do
+ putByte bh 2
+ put_ bh a
put_ bh b
+ put_ bh c
put_ bh (IfaceFunCo a b c) = do
- putByte bh 2
+ putByte bh 3
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceTyConAppCo a b c) = do
- putByte bh 3
+ putByte bh 4
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceAppCo a b) = do
- putByte bh 4
+ putByte bh 5
put_ bh a
put_ bh b
put_ bh (IfaceForAllCo a b c) = do
- putByte bh 5
+ putByte bh 6
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceCoVarCo a) = do
- putByte bh 6
+ putByte bh 7
put_ bh a
put_ bh (IfaceAxiomInstCo a b c) = do
- putByte bh 7
+ putByte bh 8
put_ bh a
put_ bh b
put_ bh c
put_ bh (IfaceUnivCo a b c d) = do
- putByte bh 8
+ putByte bh 9
put_ bh a
put_ bh b
put_ bh c
put_ bh d
put_ bh (IfaceSymCo a) = do
- putByte bh 9
- put_ bh a
- put_ bh (IfaceTransCo a b) = do
putByte bh 10
put_ bh a
- put_ bh b
- put_ bh (IfaceNthCo a b) = do
+ put_ bh (IfaceTransCo a b) = do
putByte bh 11
put_ bh a
put_ bh b
- put_ bh (IfaceLRCo a b) = do
+ put_ bh (IfaceNthCo a b) = do
putByte bh 12
put_ bh a
put_ bh b
- put_ bh (IfaceInstCo a b) = do
+ put_ bh (IfaceLRCo a b) = do
putByte bh 13
put_ bh a
put_ bh b
- put_ bh (IfaceCoherenceCo a b) = do
+ put_ bh (IfaceInstCo a b) = do
putByte bh 14
put_ bh a
put_ bh b
@@ -1368,56 +1656,61 @@ instance Binary IfaceCoercion where
putByte bh 17
put_ bh a
put_ bh b
+ put_ _ (IfaceFreeCoVar cv)
+ = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv)
+ put_ _ (IfaceHoleCo cv)
+ = pprPanic "Can't serialise IfaceHoleCo" (ppr cv)
+ -- See Note [Holes in IfaceUnivCoProv]
get bh = do
tag <- getByte bh
case tag of
1 -> do a <- get bh
- b <- get bh
- return $ IfaceReflCo a b
+ return $ IfaceReflCo a
2 -> do a <- get bh
b <- get bh
c <- get bh
- return $ IfaceFunCo a b c
+ return $ IfaceGReflCo a b c
3 -> do a <- get bh
b <- get bh
c <- get bh
- return $ IfaceTyConAppCo a b c
+ return $ IfaceFunCo a b c
4 -> do a <- get bh
b <- get bh
- return $ IfaceAppCo a b
+ c <- get bh
+ return $ IfaceTyConAppCo a b c
5 -> do a <- get bh
b <- get bh
+ return $ IfaceAppCo a b
+ 6 -> do a <- get bh
+ b <- get bh
c <- get bh
return $ IfaceForAllCo a b c
- 6 -> do a <- get bh
- return $ IfaceCoVarCo a
7 -> do a <- get bh
+ return $ IfaceCoVarCo a
+ 8 -> do a <- get bh
b <- get bh
c <- get bh
return $ IfaceAxiomInstCo a b c
- 8 -> do a <- get bh
+ 9 -> do a <- get bh
b <- get bh
c <- get bh
d <- get bh
return $ IfaceUnivCo a b c d
- 9 -> do a <- get bh
- return $ IfaceSymCo a
10-> do a <- get bh
- b <- get bh
- return $ IfaceTransCo a b
+ return $ IfaceSymCo a
11-> do a <- get bh
b <- get bh
- return $ IfaceNthCo a b
+ return $ IfaceTransCo a b
12-> do a <- get bh
b <- get bh
- return $ IfaceLRCo a b
+ return $ IfaceNthCo a b
13-> do a <- get bh
b <- get bh
- return $ IfaceInstCo a b
+ return $ IfaceLRCo a b
14-> do a <- get bh
b <- get bh
- return $ IfaceCoherenceCo a b
+ return $ IfaceInstCo a b
15-> do a <- get bh
return $ IfaceKindCo a
16-> do a <- get bh
@@ -1438,9 +1731,6 @@ instance Binary IfaceUnivCoProv where
put_ bh (IfacePluginProv a) = do
putByte bh 4
put_ bh a
- put_ _ (IfaceHoleProv _) =
- pprPanic "Binary(IfaceUnivCoProv) hit a hole" empty
- -- See Note [Holes in IfaceUnivCoProv]
get bh = do
tag <- getByte bh
diff --git a/compiler/iface/IfaceType.hs-boot b/compiler/iface/IfaceType.hs-boot
index 7488aa587c..44f1f3cfc2 100644
--- a/compiler/iface/IfaceType.hs-boot
+++ b/compiler/iface/IfaceType.hs-boot
@@ -1,18 +1,15 @@
-- Used only by ToIface.hs-boot
module IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr
- , IfaceCoercion, IfaceTyLit, IfaceTcArgs ) where
+ , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) where
-import Var (TyVarBndr, ArgFlag)
-import FastString (FastString)
+import Var (VarBndr, ArgFlag)
-data IfaceTcArgs
-type IfLclName = FastString
-type IfaceKind = IfaceType
+data IfaceAppArgs
data IfaceType
data IfaceTyCon
data IfaceTyLit
data IfaceCoercion
-type IfaceTvBndr = (IfLclName, IfaceKind)
-type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag
+data IfaceBndr
+type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index b1a3ef1e6f..34ba1cbb7a 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -6,7 +6,7 @@
Loading interface files
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module LoadIface (
-- Importing one thing
@@ -16,7 +16,7 @@ module LoadIface (
-- RnM/TcM functions
loadModuleInterface, loadModuleInterfaces,
loadSrcInterface, loadSrcInterface_maybe,
- loadInterfaceForName, loadInterfaceForModule,
+ loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,
-- IfM functions
loadInterface,
@@ -25,6 +25,7 @@ module LoadIface (
loadDecls, -- Should move to TcIface and be renamed
initExternalPackageState,
moduleFreeHolesPrecise,
+ needWiredInHomeIface, loadWiredInHomeIface,
pprModIfaceSimple,
ifaceStats, pprModIface, showIface
@@ -32,8 +33,10 @@ module LoadIface (
#include "HsVersions.h"
+import GhcPrelude
+
import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
- tcIfaceFamInst, tcIfaceVectInfo,
+ tcIfaceFamInst,
tcIfaceAnnotations, tcIfaceCompleteSigs )
import DynFlags
@@ -74,6 +77,7 @@ import Hooks
import FieldLabel
import RnModIface
import UniqDSet
+import Plugins
import Control.Monad
import Control.Exception
@@ -144,7 +148,7 @@ importDecl name
{ eps <- getEps
; case lookupTypeEnv (eps_PTE eps) name of
Just thing -> return $ Succeeded thing
- Nothing -> let doc = ifPprDebug (found_things_msg eps $$ empty)
+ Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty)
$$ not_found_msg
in return $ Failed doc
}}}
@@ -309,6 +313,15 @@ loadInterfaceForName doc name
; ASSERT2( isExternalName name, ppr name )
initIfaceTcRn $ loadSysInterface doc (nameModule name) }
+-- | Only loads the interface for external non-local names.
+loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)
+loadInterfaceForNameMaybe doc name
+ = do { this_mod <- getModule
+ ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)
+ then return Nothing
+ else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))
+ }
+
-- | Loads the interface for a given Module.
loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
loadInterfaceForModule doc m
@@ -440,6 +453,8 @@ loadInterface doc_str mod from
in
initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do
+ dontLeakTheHPT $ do
+
-- Load the new ModIface into the External Package State
-- Even home-package interfaces loaded by loadInterface
-- (which only happens in OneShot mode; in Batch/Interactive
@@ -448,7 +463,7 @@ loadInterface doc_str mod from
--
-- The main thing is to add the ModIface to the PIT, but
-- we also take the
- -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo
+ -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,
-- out of the ModIface and put them into the big EPS pools
-- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
@@ -462,7 +477,6 @@ loadInterface doc_str mod from
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
- ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface)
; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
; let { final_iface = iface {
@@ -490,8 +504,6 @@ loadInterface doc_str mod from
new_eps_insts,
eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
new_eps_fam_insts,
- eps_vect_info = plusVectInfo (eps_vect_info eps)
- new_eps_vect_info,
eps_ann_env = extendAnnEnvList (eps_ann_env eps)
new_eps_anns,
eps_mod_fam_inst_env
@@ -508,9 +520,59 @@ loadInterface doc_str mod from
(length new_eps_insts)
(length new_eps_rules) }
- ; return (Succeeded final_iface)
+ ; -- invoke plugins
+ res <- withPlugins dflags interfaceLoadAction final_iface
+ ; return (Succeeded res)
}}}}
+
+
+-- Note [HPT space leak] (#15111)
+--
+-- In IfL, we defer some work until it is demanded using forkM, such
+-- as building TyThings from IfaceDecls. These thunks are stored in
+-- the ExternalPackageState, and they might never be poked. If we're
+-- not careful, these thunks will capture the state of the loaded
+-- program when we read an interface file, and retain all that data
+-- for ever.
+--
+-- Therefore, when loading a package interface file , we use a "clean"
+-- version of the HscEnv with all the data about the currently loaded
+-- program stripped out. Most of the fields can be panics because
+-- we'll never read them, but hsc_HPT needs to be empty because this
+-- interface will cause other interfaces to be loaded recursively, and
+-- when looking up those interfaces we use the HPT in loadInterface.
+-- We know that none of the interfaces below here can refer to
+-- home-package modules however, so it's safe for the HPT to be empty.
+--
+dontLeakTheHPT :: IfL a -> IfL a
+dontLeakTheHPT thing_inside = do
+ let
+ cleanTopEnv HscEnv{..} =
+ let
+ -- wrinkle: when we're typechecking in --backpack mode, the
+ -- instantiation of a signature might reside in the HPT, so
+ -- this case breaks the assumption that EPS interfaces only
+ -- refer to other EPS interfaces. We can detect when we're in
+ -- typechecking-only mode by using hscTarget==HscNothing, and
+ -- in that case we don't empty the HPT. (admittedly this is
+ -- a bit of a hack, better suggestions welcome). A number of
+ -- tests in testsuite/tests/backpack break without this
+ -- tweak.
+ !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT
+ | otherwise = emptyHomePackageTable
+ in
+ HscEnv { hsc_targets = panic "cleanTopEnv: hsc_targets"
+ , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph"
+ , hsc_IC = panic "cleanTopEnv: hsc_IC"
+ , hsc_HPT = hpt
+ , .. }
+
+ updTopEnv cleanTopEnv $ do
+ !_ <- getTopEnv -- force the updTopEnv
+ thing_inside
+
+
-- | Returns @True@ if a 'ModIface' comes from an external package.
-- In this case, we should NOT load it into the EPS; the entities
-- should instead come from the local merged signature interface.
@@ -926,7 +988,6 @@ initExternalPackageState
-- Initialise the EPS rule pool with the built-in rules
eps_mod_fam_inst_env
= emptyModuleEnv,
- eps_vect_info = noVectInfo,
eps_complete_matches = emptyUFM,
eps_ann_env = emptyAnnEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
@@ -986,6 +1047,15 @@ ifaceStats eps
Printing interfaces
* *
************************************************************************
+
+Note [Name qualification with --show-iface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In order to disambiguate between identifiers from different modules, we qualify
+all names that don't originate in the current module. In order to keep visual
+noise as low as possible, we keep local names unqualified.
+
+For some background on this choice see trac #15269.
-}
-- | Read binary interface, and print it out
@@ -996,8 +1066,15 @@ showIface hsc_env filename = do
iface <- initTcRnIf 's' hsc_env () () $
readBinIface IgnoreHiWay TraceBinIFaceReading filename
let dflags = hsc_dflags hsc_env
+ -- See Note [Name qualification with --show-iface]
+ qualifyImportedNames mod _
+ | mod == mi_module iface = NameUnqual
+ | otherwise = NameNotInScope1
+ print_unqual = QueryQualify qualifyImportedNames
+ neverQualifyModules
+ neverQualifyPackages
putLogMsg dflags NoReason SevDump noSrcSpan
- (defaultDumpStyle dflags) (pprModIface iface)
+ (mkDumpStyle dflags print_unqual) (pprModIface iface)
-- Show a ModIface but don't display details; suitable for ModIfaces stored in
-- the EPT.
@@ -1018,6 +1095,9 @@ pprModIface iface
, nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
, nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
, nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
+ , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface))
+ , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface))
+ , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface))
, nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
, nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
, nest 2 (text "where")
@@ -1031,11 +1111,13 @@ pprModIface iface
, vcat (map ppr (mi_insts iface))
, vcat (map ppr (mi_fam_insts iface))
, vcat (map ppr (mi_rules iface))
- , pprVectInfo (mi_vect_info iface)
, ppr (mi_warns iface)
, pprTrustInfo (mi_trust iface)
, pprTrustPkg (mi_trust_pkg iface)
, vcat (map ppr (mi_complete_sigs iface))
+ , 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))
]
where
pp_hsc_src HsBootFile = text "[boot]"
@@ -1071,7 +1153,8 @@ pprUsage usage@UsageHomeModule{}
)
pprUsage usage@UsageFile{}
= hsep [text "addDependentFile",
- doubleQuotes (text (usg_file_path usage))]
+ doubleQuotes (text (usg_file_path usage)),
+ ppr (usg_file_hash usage)]
pprUsage usage@UsageMergedRequirement{}
= hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
@@ -1104,21 +1187,6 @@ pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes
where
pprFix (occ,fix) = ppr fix <+> ppr occ
-pprVectInfo :: IfaceVectInfo -> SDoc
-pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars
- , ifaceVectInfoTyCon = tycons
- , ifaceVectInfoTyConReuse = tyconsReuse
- , ifaceVectInfoParallelVars = parallelVars
- , ifaceVectInfoParallelTyCons = parallelTyCons
- }) =
- vcat
- [ text "vectorised variables:" <+> hsep (map ppr vars)
- , text "vectorised tycons:" <+> hsep (map ppr tycons)
- , text "vectorised reused tycons:" <+> hsep (map ppr tyconsReuse)
- , text "parallel variables:" <+> hsep (map ppr parallelVars)
- , text "parallel tycons:" <+> hsep (map ppr parallelTyCons)
- ]
-
pprTrustInfo :: IfaceTrustInfo -> SDoc
pprTrustInfo trust = text "trusted:" <+> ppr trust
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 78787c9827..4d2fa83f86 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -4,6 +4,7 @@
-}
{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE MultiWayIf #-}
-- | Module for constructing @ModIface@ values (interface files),
-- writing them to disk and comparing two versions to see if
@@ -58,6 +59,8 @@ Basic idea:
#include "HsVersions.h"
+import GhcPrelude
+
import IfaceSyn
import BinFingerprint
import LoadIface
@@ -83,7 +86,6 @@ import HscTypes
import Finder
import DynFlags
import VarEnv
-import VarSet
import Var
import Name
import Avail
@@ -106,6 +108,7 @@ import Fingerprint
import Exception
import UniqSet
import Packages
+import ExtractDocs
import Control.Monad
import Data.Function
@@ -115,6 +118,11 @@ import Data.Ord
import Data.IORef
import System.Directory
import System.FilePath
+import Plugins ( PluginRecompile(..), Plugin(..), LoadedPlugin(..))
+
+--Qualified import so we can define a Semigroup instance
+-- but it doesn't clash with Outputable.<>
+import qualified Data.Semigroup
{-
************************************************************************
@@ -144,12 +152,17 @@ mkIface hsc_env maybe_old_fingerprint mod_details
mg_warns = warns,
mg_hpc_info = hpc_info,
mg_safe_haskell = safe_mode,
- mg_trust_pkg = self_trust
+ mg_trust_pkg = self_trust,
+ mg_doc_hdr = doc_hdr,
+ mg_decl_docs = decl_docs,
+ mg_arg_docs = arg_docs
}
= mkIface_ hsc_env maybe_old_fingerprint
this_mod hsc_src used_th deps rdr_env fix_env
warns hpc_info self_trust
- safe_mode usages mod_details
+ safe_mode usages
+ doc_hdr decl_docs arg_docs
+ mod_details
-- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any
@@ -174,7 +187,11 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
}
= do
let used_names = mkUsedNames tc_result
- deps <- mkDependencies tc_result
+ let pluginModules =
+ map lpModule (plugins (hsc_dflags hsc_env))
+ deps <- mkDependencies
+ (thisInstalledUnitId (hsc_dflags hsc_env))
+ (map mi_module pluginModules) tc_result
let hpc_info = emptyHpcInfo other_hpc_info
used_th <- readIORef tc_splice_used
dep_files <- (readIORef dependent_files)
@@ -185,12 +202,19 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
-- but if you pass that in here, we'll decide it's the local
-- module and does not need to be recorded as a dependency.
-- See Note [Identity versus semantic module]
- usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged
+ usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names
+ dep_files merged pluginModules
+
+ let (doc_hdr', doc_map, arg_map) = extractDocs tc_result
+
mkIface_ hsc_env maybe_old_fingerprint
this_mod hsc_src
used_th deps rdr_env
fix_env warns hpc_info
- (imp_trust_own_pkg imports) safe_mode usages mod_details
+ (imp_trust_own_pkg imports) safe_mode usages
+ doc_hdr' doc_map arg_map
+ mod_details
+
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
@@ -199,16 +223,19 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
-> Bool
-> SafeHaskellMode
-> [Usage]
+ -> Maybe HsDocString
+ -> DeclDocMap
+ -> ArgDocMap
-> ModDetails
-> IO (ModIface, Bool)
mkIface_ hsc_env maybe_old_fingerprint
this_mod hsc_src used_th deps rdr_env fix_env src_warns
hpc_info pkg_trust_req safe_mode usages
+ doc_hdr decl_docs arg_docs
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
md_anns = anns,
- md_vect_info = vect_info,
md_types = type_env,
md_exports = exports,
md_complete_sigs = complete_sigs }
@@ -243,7 +270,6 @@ mkIface_ hsc_env maybe_old_fingerprint
iface_rules = map coreRuleToIfaceRule rules
iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
iface_fam_insts = map famInstToIfaceFamInst fam_insts
- iface_vect_info = flattenVectInfo vect_info
trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns
icomplete_sigs = map mkIfaceCompleteSig complete_sigs
@@ -266,8 +292,6 @@ mkIface_ hsc_env maybe_old_fingerprint
mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts,
mi_rules = sortBy cmp_rule iface_rules,
- mi_vect_info = iface_vect_info,
-
mi_fixities = fixities,
mi_warns = warns,
mi_anns = annotations,
@@ -277,7 +301,10 @@ mkIface_ hsc_env maybe_old_fingerprint
mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_flag_hash = fingerprint0,
+ mi_opt_hash = fingerprint0,
+ mi_hpc_hash = fingerprint0,
mi_exp_hash = fingerprint0,
+ mi_plugin_hash = fingerprint0,
mi_used_th = used_th,
mi_orphan_hash = fingerprint0,
mi_orphan = False, -- Always set by addFingerprints, but
@@ -292,7 +319,10 @@ mkIface_ hsc_env maybe_old_fingerprint
-- And build the cached values
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
- mi_complete_sigs = icomplete_sigs }
+ mi_complete_sigs = icomplete_sigs,
+ mi_doc_hdr = doc_hdr,
+ mi_decl_docs = decl_docs,
+ mi_arg_docs = arg_docs }
(new_iface, no_change_at_all)
<- {-# SCC "versioninfo" #-}
@@ -335,19 +365,6 @@ mkIface_ hsc_env maybe_old_fingerprint
ifFamInstTcName = ifFamInstFam
- flattenVectInfo (VectInfo { vectInfoVar = vVar
- , vectInfoTyCon = vTyCon
- , vectInfoParallelVars = vParallelVars
- , vectInfoParallelTyCons = vParallelTyCons
- }) =
- IfaceVectInfo
- { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- dVarEnvElts vVar]
- , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
- , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
- , ifaceVectInfoParallelVars = [Var.varName v | v <- dVarSetElems vParallelVars]
- , ifaceVectInfoParallelTyCons = nameSetElemsStable vParallelTyCons
- }
-
-----------------------------
writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile dflags hi_file_path new_iface
@@ -658,18 +675,22 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
-- the abi hash and one that should
flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
+ opt_hash <- fingerprintOptFlags dflags putNameLiterally
+
+ hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
+
+ plugin_hash <- fingerprintPlugins hsc_env
+
-- the ABI hash depends on:
-- - decls
-- - export list
-- - orphans
-- - deprecations
- -- - vect info
-- - flag abi hash
mod_hash <- computeFingerprint putNameLiterally
(map fst sorted_decls,
export_hash, -- includes orphan_hash
- mi_warns iface0,
- mi_vect_info iface0)
+ mi_warns iface0)
-- The interface hash depends on:
-- - the ABI hash, plus
@@ -693,11 +714,13 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
mi_exp_hash = export_hash,
mi_orphan_hash = orphan_hash,
mi_flag_hash = flag_hash,
+ mi_opt_hash = opt_hash,
+ mi_hpc_hash = hpc_hash,
+ mi_plugin_hash = plugin_hash,
mi_orphan = not ( all ifRuleAuto orph_rules
-- See Note [Orphans and auto-generated rules]
&& null orph_insts
- && null orph_fis
- && isNoIfaceVectInfo (mi_vect_info iface0)),
+ && null orph_fis),
mi_finsts = not . null $ mi_fam_insts iface0,
mi_decls = sorted_decls,
mi_hash_fn = lookupOccEnv local_env }
@@ -768,7 +791,8 @@ sortDependencies d
= Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
- dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
+ dep_finsts = sortBy stableModuleCmp (dep_finsts d),
+ dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }
-- | Creates cached lookup for the 'mi_anns' field of ModIface
-- Hackily, we use "module" as the OccName for any module-level annotations
@@ -989,7 +1013,7 @@ mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
-- each sublist in canonical order
[decl]) -- Orphan decls; in canonical order
mkOrphMap get_key decls
- = foldl go (emptyOccEnv, []) decls
+ = foldl' go (emptyOccEnv, []) decls
where
go (non_orphs, orphs) d
| NotOrphan occ <- get_key d
@@ -1082,6 +1106,16 @@ data RecompileRequired
-- to force recompilation; the String says what (one-line summary)
deriving Eq
+instance Semigroup RecompileRequired where
+ UpToDate <> r = r
+ mc <> _ = mc
+
+instance Monoid RecompileRequired where
+ mempty = UpToDate
+#if __GLASGOW_HASKELL__ < 804
+ mappend = (Data.Semigroup.<>)
+#endif
+
recompileRequired :: RecompileRequired -> Bool
recompileRequired UpToDate = False
recompileRequired _ = True
@@ -1198,12 +1232,19 @@ checkVersions hsc_env mod_summary iface
then return (RecompBecause "-this-unit-id changed", Nothing) else do {
; recomp <- checkFlagHash hsc_env iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkOptimHash hsc_env iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+ ; recomp <- checkHpcHash hsc_env iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkMergedSignatures mod_summary iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkHsig mod_summary iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- checkDependencies hsc_env mod_summary iface
; if recompileRequired recomp then return (recomp, Just iface) else do {
+ ; recomp <- checkPlugins hsc_env iface
+ ; if recompileRequired recomp then return (recomp, Nothing) else do {
+
-- Source code unchanged and no errors yet... carry on
--
@@ -1221,13 +1262,51 @@ checkVersions hsc_env mod_summary iface
; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps }
; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
; return (recomp, Just iface)
- }}}}}}
+ }}}}}}}}}
where
this_pkg = thisPackage (hsc_dflags hsc_env)
-- This is a bit of a hack really
mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
mod_deps = mkModDeps (dep_mods (mi_deps iface))
+-- | Check if any plugins are requesting recompilation
+checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
+checkPlugins hsc iface = liftIO $ do
+ -- [(ModuleName, Plugin, [Opts])]
+ let old_fingerprint = mi_plugin_hash iface
+ loaded_plugins = plugins (hsc_dflags hsc)
+ res <- mconcat <$> mapM checkPlugin loaded_plugins
+ return (pluginRecompileToRecompileRequired old_fingerprint res)
+
+fingerprintPlugins :: HscEnv -> IO Fingerprint
+fingerprintPlugins hsc_env = do
+ fingerprintPlugins' (plugins (hsc_dflags hsc_env))
+
+fingerprintPlugins' :: [LoadedPlugin] -> IO Fingerprint
+fingerprintPlugins' plugins = do
+ res <- mconcat <$> mapM checkPlugin plugins
+ return $ case res of
+ NoForceRecompile -> fingerprintString "NoForceRecompile"
+ ForceRecompile -> fingerprintString "ForceRecompile"
+ -- is the chance of collision worth worrying about?
+ -- An alternative is to fingerprintFingerprints [fingerprintString
+ -- "maybeRecompile", fp]
+ (MaybeRecompile fp) -> fp
+
+
+
+checkPlugin :: LoadedPlugin -> IO PluginRecompile
+checkPlugin (LoadedPlugin plugin _ opts) = pluginRecompile plugin opts
+
+pluginRecompileToRecompileRequired :: Fingerprint -> PluginRecompile -> RecompileRequired
+pluginRecompileToRecompileRequired old_fp pr =
+ case pr of
+ NoForceRecompile -> UpToDate
+ ForceRecompile -> RecompBecause "Plugin forced recompilation"
+ MaybeRecompile fp -> if fp == old_fp then UpToDate
+ else RecompBecause "Plugin fingerprint changed"
+
+
-- | Check if an hsig file needs recompilation because its
-- implementing module has changed.
checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
@@ -1253,6 +1332,36 @@ checkFlagHash hsc_env iface = do
(text " Module flags have changed")
old_hash new_hash
+-- | Check the optimisation flags haven't changed
+checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkOptimHash hsc_env iface = do
+ let old_hash = mi_opt_hash iface
+ new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)
+ putNameLiterally
+ if | old_hash == new_hash
+ -> up_to_date (text "Optimisation flags unchanged")
+ | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
+ -> up_to_date (text "Optimisation flags changed; ignoring")
+ | otherwise
+ -> out_of_date_hash "Optimisation flags changed"
+ (text " Optimisation flags have changed")
+ old_hash new_hash
+
+-- | Check the HPC flags haven't changed
+checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkHpcHash hsc_env iface = do
+ let old_hash = mi_hpc_hash iface
+ new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)
+ putNameLiterally
+ if | old_hash == new_hash
+ -> up_to_date (text "HPC flags unchanged")
+ | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
+ -> up_to_date (text "HPC flags changed; ignoring")
+ | otherwise
+ -> out_of_date_hash "HPC flags changed"
+ (text " HPC flags have changed")
+ old_hash new_hash
+
-- Check that the set of signatures we are merging in match.
-- If the -unit-id flags change, this can change too.
checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
@@ -1282,6 +1391,7 @@ checkDependencies hsc_env summary iface
= checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
where
prev_dep_mods = dep_mods (mi_deps iface)
+ prev_dep_plgn = dep_plgins (mi_deps iface)
prev_dep_pkgs = dep_pkgs (mi_deps iface)
this_pkg = thisPackage (hsc_dflags hsc_env)
@@ -1292,7 +1402,7 @@ checkDependencies hsc_env summary iface
case find_res of
Found _ mod
| pkg == this_pkg
- -> if moduleName mod `notElem` map fst prev_dep_mods
+ -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn
then do traceHiDiffs $
text "imported module " <> quotes (ppr mod) <>
text " not among previous dependencies"
@@ -1536,7 +1646,7 @@ coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
, ifaxbRHS = tidyToIfaceType env1 rhs
, ifaxbIncomps = [] }
where
- (env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs
+ (env1, tidy_tvs) = tidyVarBndrs emptyTidyEnv tvs
-- Don't re-bind in-scope tyvars
-- See Note [CoAxBranch type variables] in CoAxiom
@@ -1565,7 +1675,7 @@ tyConToIfaceDecl env tycon
ifFamFlav = to_if_fam_flav fam_flav,
ifBinders = if_binders,
ifResKind = if_res_kind,
- ifFamInj = familyTyConInjectivityInfo tycon
+ ifFamInj = tyConInjectivityInfo tycon
})
| isAlgTyCon tycon
@@ -1600,7 +1710,7 @@ tyConToIfaceDecl env tycon
-- an error.
(tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
tc_tyvars = binderVars tc_binders
- if_binders = toIfaceTyVarBinders tc_binders
+ if_binders = toIfaceTyCoVarBinders tc_binders
if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
if_syn_type ty = tidyToIfaceType tc_env1 ty
if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon
@@ -1641,7 +1751,8 @@ tyConToIfaceDecl env tycon
= IfCon { ifConName = dataConName data_con,
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
- ifConExTvs = map toIfaceForAllBndr ex_bndrs',
+ ifConExTCvs = map toIfaceBndr ex_tvs',
+ ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',
ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
ifConCtxt = tidyToIfaceContext con_env2 theta,
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
@@ -1651,9 +1762,9 @@ tyConToIfaceDecl env tycon
ifConSrcStricts = map toIfaceSrcBang
(dataConSrcBangs data_con)}
where
- (univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _)
+ (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
= dataConFullSig data_con
- ex_bndrs = dataConExTyVarBinders data_con
+ user_bndrs = dataConUserTyVarBinders data_con
-- Tidy the univ_tvs of the data constructor to be identical
-- to the tyConTyVars of the type constructor. This means
@@ -1665,15 +1776,27 @@ tyConToIfaceDecl env tycon
con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
-- A bit grimy, perhaps, but it's simple!
- (con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs
+ (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs
+ user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs
to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
+ -- By this point, we have tidied every universal and existential
+ -- tyvar. Because of the dcUserTyCoVarBinders invariant
+ -- (see Note [DataCon user type variable binders]), *every*
+ -- user-written tyvar must be contained in the substitution that
+ -- tidying produced. Therefore, tidying the user-written tyvars is a
+ -- simple matter of looking up each variable in the substitution,
+ -- which tidyTyCoVarOcc accomplishes.
+ tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder
+ tidyUserTyCoVarBinder env (Bndr tv vis) =
+ Bndr (tidyTyCoVarOcc env tv) vis
+
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
= ( env1
, IfaceClass { ifName = getName tycon,
ifRoles = tyConRoles (classTyCon clas),
- ifBinders = toIfaceTyVarBinders tc_binders,
+ ifBinders = toIfaceTyCoVarBinders tc_binders,
ifBody = body,
ifFDs = map toIfaceFD clas_fds })
where
@@ -1725,10 +1848,10 @@ tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
-- If the type variable "binder" is in scope, don't re-bind it
-- In a class decl, for example, the ATD binders mention
-- (amd must mention) the class tyvars
-tidyTyConBinder env@(_, subst) tvb@(TvBndr tv vis)
+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
= case lookupVarEnv subst tv of
- Just tv' -> (env, TvBndr tv' vis)
- Nothing -> tidyTyVarBinder env tvb
+ Just tv' -> (env, Bndr tv' vis)
+ Nothing -> tidyTyCoVarBinder env tvb
tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
tidyTyConBinders = mapAccumL tidyTyConBinder
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 1477f462fc..248f7d3c38 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -15,13 +15,15 @@ module TcIface (
typecheckIfacesForMerging,
typecheckIfaceForInstantiate,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
- tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceCompleteSigs,
+ tcIfaceAnnotations, tcIfaceCompleteSigs,
tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
tcIfaceGlobal
) where
#include "HsVersions.h"
+import GhcPrelude
+
import TcTypeNats(typeNatCoAxiomRules)
import IfaceSyn
import LoadIface
@@ -53,7 +55,6 @@ import PrelNames
import TysWiredIn
import Literal
import Var
-import VarEnv
import VarSet
import Name
import NameEnv
@@ -74,7 +75,6 @@ import ListSetOps
import GHC.Fingerprint
import qualified BooleanFormula as BF
-import Data.List
import Control.Monad
import qualified Data.Map as Map
@@ -171,9 +171,6 @@ typecheckIface iface
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
; anns <- tcIfaceAnnotations (mi_anns iface)
- -- Vectorisation information
- ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
-
-- Exports
; exports <- ifaceExportNames (mi_exports iface)
@@ -191,7 +188,6 @@ typecheckIface iface
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
- , md_vect_info = vect_info
, md_exports = exports
, md_complete_sigs = complete_sigs
}
@@ -391,7 +387,6 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
- vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
exports <- ifaceExportNames (mi_exports iface)
complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
return $ ModDetails { md_types = type_env
@@ -399,7 +394,6 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
- , md_vect_info = vect_info
, md_exports = exports
, md_complete_sigs = complete_sigs
}
@@ -432,7 +426,6 @@ typecheckIfaceForInstantiate nsubst iface =
fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
rules <- tcIfaceRules ignore_prags (mi_rules iface)
anns <- tcIfaceAnnotations (mi_anns iface)
- vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface)
exports <- ifaceExportNames (mi_exports iface)
complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
return $ ModDetails { md_types = type_env
@@ -440,7 +433,6 @@ typecheckIfaceForInstantiate nsubst iface =
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
- , md_vect_info = vect_info
, md_exports = exports
, md_complete_sigs = complete_sigs
}
@@ -645,7 +637,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
ifIdDetails = details, ifIdInfo = info})
= do { ty <- tcIfaceType iface_type
; details <- tcIdDetails ty details
- ; info <- tcIdInfo ignore_prags name ty info
+ ; info <- tcIdInfo ignore_prags TopLevel name ty info
; return (AnId (mkGlobalId details name ty info)) }
tc_iface_decl _ _ (IfaceData {ifName = tc_name,
@@ -677,7 +669,7 @@ tc_iface_decl _ _ (IfaceData {ifName = tc_name,
= do { ax <- tcIfaceCoAxiom ax_name
; let fam_tc = coAxiomTyCon ax
ax_unbr = toUnbranchedAxiom ax
- ; lhs_tys <- tcIfaceTcArgs arg_tys
+ ; lhs_tys <- tcIfaceAppArgs arg_tys
; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
@@ -869,10 +861,10 @@ tc_ax_branch prev_branches
, ifaxbLHS = lhs, ifaxbRHS = rhs
, ifaxbRoles = roles, ifaxbIncomps = incomps })
= bindIfaceTyConBinders_AT
- (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
+ (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
-- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
bindIfaceIds cv_bndrs $ \ cvs -> do
- { tc_lhs <- tcIfaceTcArgs lhs
+ { tc_lhs <- tcIfaceAppArgs lhs
; tc_rhs <- tcIfaceType rhs
; let br = CoAxBranch { cab_loc = noSrcSpan
, cab_tvs = binderVars tvs
@@ -892,11 +884,15 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
IfNewTyCon con -> do { data_con <- tc_con_decl con
; mkNewTyConRhs tycon_name tycon data_con }
where
- univ_tv_bndrs :: [TyVarBinder]
- univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders
+ univ_tvs :: [TyVar]
+ univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)
+
+ tag_map :: NameEnv ConTag
+ tag_map = mkTyConTagMap tycon
tc_con_decl (IfCon { ifConInfix = is_infix,
- ifConExTvs = ex_bndrs,
+ ifConExTCvs = ex_bndrs,
+ ifConUserTvBinders = user_bndrs,
ifConName = dc_name,
ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = lbl_names,
@@ -904,9 +900,23 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
ifConSrcStricts = if_src_stricts})
= -- Universally-quantified tyvars are shared with
-- parent TyCon, and are already in scope
- bindIfaceForAllBndrs ex_bndrs $ \ ex_tv_bndrs -> do
+ bindIfaceBndrs ex_bndrs $ \ ex_tvs -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
+ -- By this point, we have bound every universal and existential
+ -- tyvar. Because of the dcUserTyVarBinders invariant
+ -- (see Note [DataCon user type variable binders]), *every* tyvar in
+ -- ifConUserTvBinders has a matching counterpart somewhere in the
+ -- bound universals/existentials. As a result, calling tcIfaceTyVar
+ -- below is always guaranteed to succeed.
+ ; user_tv_bndrs <- mapM (\(Bndr bd vis) ->
+ case bd of
+ IfaceIdBndr (name, _) ->
+ Bndr <$> tcIfaceLclId name <*> pure vis
+ IfaceTvBndr (name, _) ->
+ Bndr <$> tcIfaceTyVar name <*> pure vis)
+ user_bndrs
+
-- Read the context and argument types, but lazily for two reasons
-- (a) to avoid looking tugging on a recursive use of
-- the type itself, which is knot-tied
@@ -915,7 +925,14 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
do { eq_spec <- tcIfaceEqSpec spec
; theta <- tcIfaceCtxt ctxt
- ; arg_tys <- mapM tcIfaceType args
+ -- This fixes #13710. The enclosing lazy thunk gets
+ -- forced when typechecking record wildcard pattern
+ -- matching (it's not completely clear why this
+ -- tuple is needed), which causes trouble if one of
+ -- the argument types was recursively defined.
+ -- See also Note [Tying the knot]
+ ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
+ $ mapM tcIfaceType args
; stricts <- mapM tc_strict if_stricts
-- The IfBang field can mention
-- the type itself; hence inside forkM
@@ -923,7 +940,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
-- Remember, tycon is the representation tycon
; let orig_res_ty = mkFamilyTyConApp tycon
- (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
+ (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))
(binderVars tc_tybinders))
; prom_rep_name <- newTyConRepName dc_name
@@ -938,9 +955,9 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
-- worker.
-- See Note [Bangs on imported data constructors] in MkId
lbl_names
- univ_tv_bndrs ex_tv_bndrs
+ univ_tvs ex_tvs user_tv_bndrs
eq_spec theta
- arg_tys orig_res_ty tycon
+ arg_tys orig_res_ty tycon tag_map
; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
; return con }
mk_doc con_name = text "Constructor" <+> ppr con_name
@@ -1060,7 +1077,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
-- to write them out in coreRuleToIfaceRule
ifTopFreeName :: IfaceExpr -> Maybe Name
ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
- ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (tcArgsIfaceTypes ts)))
+ ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
ifTopFreeName (IfaceApp f _) = ifTopFreeName f
ifTopFreeName (IfaceExt n) = Just n
ifTopFreeName _ = Nothing
@@ -1108,134 +1125,6 @@ tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
{-
************************************************************************
* *
- Vectorisation information
-* *
-************************************************************************
--}
-
--- We need access to the type environment as we need to look up information about type constructors
--- (i.e., their data constructors and whether they are class type constructors). If a vectorised
--- type constructor or class is defined in the same module as where it is vectorised, we cannot
--- look that information up from the type constructor that we obtained via a 'forkM'ed
--- 'tcIfaceTyCon' without recursively loading the interface that we are already type checking again
--- and again and again...
---
-tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
-tcIfaceVectInfo mod typeEnv (IfaceVectInfo
- { ifaceVectInfoVar = vars
- , ifaceVectInfoTyCon = tycons
- , ifaceVectInfoTyConReuse = tyconsReuse
- , ifaceVectInfoParallelVars = parallelVars
- , ifaceVectInfoParallelTyCons = parallelTyCons
- })
- = do { let parallelTyConsSet = mkNameSet parallelTyCons
- ; vVars <- mapM vectVarMapping vars
- ; let varsSet = mkVarSet (map fst vVars)
- ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
- ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
- ; vParallelVars <- mapM vectVar parallelVars
- ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
- ; return $ VectInfo
- { vectInfoVar = mkDVarEnv vVars `extendDVarEnvList` concat vScSels
- , vectInfoTyCon = mkNameEnv vTyCons
- , vectInfoDataCon = mkNameEnv (concat vDataCons)
- , vectInfoParallelVars = mkDVarSet vParallelVars
- , vectInfoParallelTyCons = parallelTyConsSet
- }
- }
- where
- vectVarMapping name
- = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectOcc name)
- ; var <- forkM (text "vect var" <+> ppr name) $
- tcIfaceExtId name
- ; vVar <- forkM (text "vect vVar [mod =" <+>
- ppr mod <> text "; nameModule =" <+>
- ppr (nameModule name) <> text "]" <+> ppr vName) $
- tcIfaceExtId vName
- ; return (var, (var, vVar))
- }
- -- where
- -- lookupLocalOrExternalId name
- -- = do { let mb_id = lookupTypeEnv typeEnv name
- -- ; case mb_id of
- -- -- id is local
- -- Just (AnId id) -> return id
- -- -- name is not an Id => internal inconsistency
- -- Just _ -> notAnIdErr
- -- -- Id is external
- -- Nothing -> tcIfaceExtId name
- -- }
- --
- -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
-
- vectVar name
- = forkM (text "vect scalar var" <+> ppr name) $
- tcIfaceExtId name
-
- vectTyConVectMapping vars name
- = do { vName <- lookupIfaceTop (mkLocalisedOccName mod mkVectTyConOcc name)
- ; vectTyConMapping vars name vName
- }
-
- vectTyConReuseMapping vars name
- = vectTyConMapping vars name name
-
- vectTyConMapping vars name vName
- = do { tycon <- lookupLocalOrExternalTyCon name
- ; vTycon <- forkM (text "vTycon of" <+> ppr vName) $
- lookupLocalOrExternalTyCon vName
-
- -- Map the data constructors of the original type constructor to those of the
- -- vectorised type constructor /unless/ the type constructor was vectorised
- -- abstractly; if it was vectorised abstractly, the workers of its data constructors
- -- do not appear in the set of vectorised variables.
- --
- -- NB: This is lazy! We don't pull at the type constructors before we actually use
- -- the data constructor mapping.
- ; let isAbstract | isClassTyCon tycon = False
- | datacon:_ <- tyConDataCons tycon
- = not $ dataConWrapId datacon `elemVarSet` vars
- | otherwise = True
- vDataCons | isAbstract = []
- | otherwise = [ (dataConName datacon, (datacon, vDatacon))
- | (datacon, vDatacon) <- zip (tyConDataCons tycon)
- (tyConDataCons vTycon)
- ]
-
- -- Map the (implicit) superclass and methods selectors as they don't occur in
- -- the var map.
- vScSels | Just cls <- tyConClass_maybe tycon
- , Just vCls <- tyConClass_maybe vTycon
- = [ (sel, (sel, vSel))
- | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
- ]
- | otherwise
- = []
-
- ; return ( (name, (tycon, vTycon)) -- (T, T_v)
- , vDataCons -- list of (Ci, Ci_v)
- , vScSels -- list of (seli, seli_v)
- )
- }
- where
- -- we need a fully defined version of the type constructor to be able to extract
- -- its data constructors etc.
- lookupLocalOrExternalTyCon name
- = do { let mb_tycon = lookupTypeEnv typeEnv name
- ; case mb_tycon of
- -- tycon is local
- Just (ATyCon tycon) -> return tycon
- -- name is not a tycon => internal inconsistency
- Just _ -> notATyConErr
- -- tycon is external
- Nothing -> tcIfaceTyConByName name
- }
-
- notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
-
-{-
-************************************************************************
-* *
Types
* *
************************************************************************
@@ -1246,24 +1135,27 @@ tcIfaceType = go
where
go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
- go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2
go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2
go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2
go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
+ go (IfaceAppTy t ts)
+ = do { t' <- go t
+ ; ts' <- traverse go (appArgsIfaceTypes ts)
+ ; pure (foldl' AppTy t' ts') }
go (IfaceTyConApp tc tks)
= do { tc' <- tcIfaceTyCon tc
- ; tks' <- mapM go (tcArgsIfaceTypes tks)
+ ; tks' <- mapM go (appArgsIfaceTypes tks)
; return (mkTyConApp tc' tks') }
go (IfaceForAllTy bndr t)
= bindIfaceForAllBndr bndr $ \ tv' vis ->
- ForAllTy (TvBndr tv' vis) <$> go t
+ ForAllTy (Bndr tv' vis) <$> go t
go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
-tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceTcArgs -> IfL Type
+tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceAppArgs -> IfL Type
tcIfaceTupleTy sort is_promoted args
- = do { args' <- tcIfaceTcArgs args
+ = do { args' <- tcIfaceAppArgs args
; let arity = length args'
; base_tc <- tcTupleTyCon True sort arity
; case is_promoted of
@@ -1290,8 +1182,8 @@ tcTupleTyCon in_type sort arity
| otherwise = arity
-- in expressions, we only have term args
-tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
-tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes
+tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]
+tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
@@ -1313,13 +1205,17 @@ tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
tcIfaceCo :: IfaceCoercion -> IfL Coercion
tcIfaceCo = go
where
- go (IfaceReflCo r t) = Refl r <$> tcIfaceType t
+ go_mco IfaceMRefl = pure MRefl
+ go_mco (IfaceMCo co) = MCo <$> (go co)
+
+ go (IfaceReflCo t) = Refl <$> tcIfaceType t
+ go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco
go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
go (IfaceTyConAppCo r tc cs)
= TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
go (IfaceForAllCo tv k c) = do { k' <- go k
- ; bindIfaceTyVar tv $ \ tv' ->
+ ; bindIfaceBndr tv $ \ tv' ->
ForAllCo tv' k' <$> go c }
go (IfaceCoVarCo n) = CoVarCo <$> go_var n
go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
@@ -1330,31 +1226,24 @@ tcIfaceCo = go
<*> go c2
go (IfaceInstCo c1 t2) = InstCo <$> go c1
<*> go t2
- go (IfaceNthCo d c) = NthCo d <$> go c
+ go (IfaceNthCo d c) = do { c' <- go c
+ ; return $ mkNthCo (nthCoRole d c') d c' }
go (IfaceLRCo lr c) = LRCo lr <$> go c
- go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1
- <*> go c2
go (IfaceKindCo c) = KindCo <$> go c
go (IfaceSubCo c) = SubCo <$> go c
- go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax
+ go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
<*> mapM go cos
+ go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
+ go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c)
go_var :: FastString -> IfL CoVar
go_var = tcIfaceLclId
- go_axiom_rule :: FastString -> IfL CoAxiomRule
- go_axiom_rule n =
- case Map.lookup n typeNatCoAxiomRules of
- Just ax -> return ax
- _ -> pprPanic "go_axiom_rule" (ppr n)
-
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
-tcIfaceUnivCoProv (IfaceHoleProv _) =
- pprPanic "tcIfaceUnivCoProv" (text "holes can't occur in interface files")
{-
************************************************************************
@@ -1396,7 +1285,7 @@ tcIfaceExpr (IfaceTuple sort args)
; let con_tys = map exprType args'
some_con_args = map Type con_tys ++ args'
con_args = case sort of
- UnboxedTuple -> map (Type . getRuntimeRep "tcIfaceExpr") con_tys ++ some_con_args
+ UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
_ -> some_con_args
-- Put the missing type arguments back in
con_id = dataConWorkId (tyConSingleDataCon tc)
@@ -1440,7 +1329,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
- name ty' info
+ NotTopLevel name ty' info
; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
`asJoinId_maybe` tcJoinInfo ji
; rhs' <- tcIfaceExpr rhs
@@ -1461,7 +1350,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
tc_pair (IfLetBndr _ _ info _, rhs) id
= do { rhs' <- tcIfaceExpr rhs
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
- (idName id) (idType id) info
+ NotTopLevel (idName id) (idType id) info
; return (setIdInfo id id_info, rhs') }
tcIfaceExpr (IfaceTick tickish expr) = do
@@ -1486,9 +1375,15 @@ tcIfaceLit :: Literal -> IfL Literal
-- Integer literals deserialise to (LitInteger i <error thunk>)
-- so tcIfaceLit just fills in the type.
-- See Note [Integer literals] in Literal
-tcIfaceLit (LitInteger i _)
+tcIfaceLit (LitNumber LitNumInteger i _)
= do t <- tcIfaceTyConByName integerTyConName
return (mkLitInteger i (mkTyConTy t))
+-- Natural literals deserialise to (LitNatural i <error thunk>)
+-- so tcIfaceLit just fills in the type.
+-- See Note [Natural literals] in Literal
+tcIfaceLit (LitNumber LitNumNatural i _)
+ = do t <- tcIfaceTyConByName naturalTyConName
+ return (mkLitNatural i (mkTyConTy t))
tcIfaceLit lit = return lit
-------------------------
@@ -1552,8 +1447,8 @@ tcIdDetails _ (IfRecSelId tc naughty)
tyThingPatSyn (AConLike (PatSynCon ps)) = ps
tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
-tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
-tcIdInfo ignore_prags name ty info = do
+tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo ignore_prags toplvl name ty info = do
lcl_env <- getLclEnv
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
@@ -1574,7 +1469,7 @@ tcIdInfo ignore_prags name ty info = do
-- The next two are lazy, so they don't transitively suck stuff in
tcPrag info (HsUnfold lb if_unf)
- = do { unf <- tcUnfolding name ty info if_unf
+ = do { unf <- tcUnfolding toplvl name ty info if_unf
; let info1 | lb = info `setOccInfo` strongLoopBreaker
| otherwise = info
; return (info1 `setUnfoldingInfo` unf) }
@@ -1583,10 +1478,10 @@ tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
tcJoinInfo (IfaceJoinPoint ar) = Just ar
tcJoinInfo IfaceNotJoinPoint = Nothing
-tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-tcUnfolding name _ info (IfCoreUnfold stable if_expr)
+tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags
- ; mb_expr <- tcPragExpr name if_expr
+ ; mb_expr <- tcPragExpr toplvl name if_expr
; let unf_src | stable = InlineStable
| otherwise = InlineRhs
; return $ case mb_expr of
@@ -1599,21 +1494,21 @@ tcUnfolding name _ info (IfCoreUnfold stable if_expr)
where
-- Strictness should occur before unfolding!
strict_sig = strictnessInfo info
-tcUnfolding name _ _ (IfCompulsory if_expr)
- = do { mb_expr <- tcPragExpr name if_expr
+tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
+ = do { mb_expr <- tcPragExpr toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCompulsoryUnfolding expr) }
-tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
- = do { mb_expr <- tcPragExpr name if_expr
+tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+ = do { mb_expr <- tcPragExpr toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
where
guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
-tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
+tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
= bindIfaceBndrs bs $ \ bs' ->
do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
; return (case mb_ops1 of
@@ -1628,13 +1523,14 @@ For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
-}
-tcPragExpr :: Name -> IfaceExpr -> IfL (Maybe CoreExpr)
-tcPragExpr name expr
+tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
+tcPragExpr toplvl name expr
= forkM_maybe doc $ do
core_expr' <- tcIfaceExpr expr
- -- Check for type consistency in the unfolding
- whenGOptM Opt_DoCoreLinting $ do
+ -- Check for type consistency in the unfolding
+ -- See Note [Linting Unfoldings from Interfaces]
+ when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
in_scope <- get_in_scope
dflags <- getDynFlags
case lintUnfolding dflags noSrcLoc in_scope core_expr' of
@@ -1692,13 +1588,13 @@ tcIfaceGlobal name
{ type_env <- setLclEnv () get_type_env -- yuk
; case lookupNameEnv type_env name of
Just thing -> return thing
- Nothing ->
- pprPanic "tcIfaceGlobal (local): not found"
- (ifKnotErr name (if_doc env) type_env)
+ -- See Note [Knot-tying fallback on boot]
+ Nothing -> via_external
}
- ; _ -> do
-
+ ; _ -> via_external }}
+ where
+ via_external = do
{ hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
; case mb_thing of {
@@ -1709,21 +1605,7 @@ tcIfaceGlobal name
; case mb_thing of
Failed err -> failIfM err
Succeeded thing -> return thing
- }}}}}
-
-ifKnotErr :: Name -> SDoc -> TypeEnv -> SDoc
-ifKnotErr name env_doc type_env = vcat
- [ text "You are in a maze of twisty little passages, all alike."
- , text "While forcing the thunk for TyThing" <+> ppr name
- , text "which was lazily initialized by" <+> env_doc <> text ","
- , text "I tried to tie the knot, but I couldn't find" <+> ppr name
- , text "in the current type environment."
- , text "If you are developing GHC, please read Note [Tying the knot]"
- , text "and Note [Type-checking inside the knot]."
- , text "Consider rebuilding GHC with profiling for a better stack trace."
- , hang (text "Contents of current type environment:")
- 2 (ppr type_env)
- ]
+ }}}
-- Note [Tying the knot]
-- ~~~~~~~~~~~~~~~~~~~~~
@@ -1738,11 +1620,50 @@ ifKnotErr name env_doc type_env = vcat
-- * Note [Knot-tying typecheckIface]
-- * Note [DFun knot-tying]
-- * Note [hsc_type_env_var hack]
+-- * Note [Knot-tying fallback on boot]
--
-- There is also a wiki page on the subject, see:
--
-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot
+-- Note [Knot-tying fallback on boot]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Suppose that you are typechecking A.hs, which transitively imports,
+-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
+-- has a reference to a type T from A, what TyThing should we wire
+-- it up with? Clearly, if we have already typechecked T and
+-- added it into the type environment, we should go ahead and use that
+-- type. But what if we haven't typechecked it yet?
+--
+-- For the longest time, GHC adopted the policy that this was
+-- *an error condition*; that you MUST NEVER poke on B.hs's reference
+-- to a T defined in A.hs until A.hs has gotten around to kind-checking
+-- T and adding it to the env. However, actually ensuring this is the
+-- case has proven to be a bug farm, because it's really difficult to
+-- actually ensure this never happens. The problem was especially poignant
+-- with type family consistency checks, which eagerly happen before any
+-- typechecking takes place.
+--
+-- Today, we take a different strategy: if we ever try to access
+-- an entity from A which doesn't exist, we just fall back on the
+-- definition of A from the hs-boot file. This is complicated in
+-- its own way: it means that you may end up with a mix of A.hs and
+-- A.hs-boot TyThings during the course of typechecking. We don't
+-- think (and have not observed) any cases where this would cause
+-- problems, but the hypothetical situation one might worry about
+-- is something along these lines in Core:
+--
+-- case x of
+-- A -> e1
+-- B -> e2
+--
+-- If, when typechecking this, we find x :: T, and the T we are hooked
+-- up with is the abstract one from the hs-boot file, rather than the
+-- one defined in this module with constructors A and B. But it's hard
+-- to see how this could happen, especially because the reference to
+-- the constructor (A and B) means that GHC will always typecheck
+-- this expression *after* typechecking T.
+
tcIfaceTyConByName :: IfExtName -> IfL TyCon
tcIfaceTyConByName name
= do { thing <- tcIfaceGlobal name
@@ -1759,6 +1680,16 @@ tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
; return (tyThingCoAxiom thing) }
+
+tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
+-- Unlike CoAxioms, which arise form user 'type instance' declarations,
+-- there are a fixed set of CoAxiomRules,
+-- currently enumerated in typeNatCoAxiomRules
+tcIfaceCoAxiomRule n
+ = case Map.lookup n typeNatCoAxiomRules of
+ Just ax -> return ax
+ _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
+
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
@@ -1818,16 +1749,18 @@ bindIfaceBndrs (b:bs) thing_inside
thing_inside (b':bs')
-----------------------
-bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a
+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a
bindIfaceForAllBndrs [] thing_inside = thing_inside []
bindIfaceForAllBndrs (bndr:bndrs) thing_inside
= bindIfaceForAllBndr bndr $ \tv vis ->
bindIfaceForAllBndrs bndrs $ \bndrs' ->
- thing_inside (mkTyVarBinder vis tv : bndrs')
+ thing_inside (mkTyCoVarBinder vis tv : bndrs')
-bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a
-bindIfaceForAllBndr (TvBndr tv vis) thing_inside
+bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a
+bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside
= bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
+bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
+ = bindIfaceId tv $ \tv' -> thing_inside tv' vis
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
@@ -1844,8 +1777,8 @@ bindIfaceTyConBinders :: [IfaceTyConBinder]
-> ([TyConBinder] -> IfL a) -> IfL a
bindIfaceTyConBinders [] thing_inside = thing_inside []
bindIfaceTyConBinders (b:bs) thing_inside
- = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' ->
- bindIfaceTyConBinders bs $ \ bs' ->
+ = bindIfaceTyConBinderX bindIfaceBndr b $ \ b' ->
+ bindIfaceTyConBinders bs $ \ bs' ->
thing_inside (b':bs')
bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
@@ -1862,14 +1795,14 @@ bindIfaceTyConBinders_AT (b : bs) thing_inside
thing_inside (b':bs')
where
bind_tv tv thing
- = do { mb_tv <- lookupIfaceTyVar tv
+ = do { mb_tv <- lookupIfaceVar tv
; case mb_tv of
Just b' -> thing b'
- Nothing -> bindIfaceTyVar tv thing }
+ Nothing -> bindIfaceBndr tv thing }
-bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a)
+bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
-> IfaceTyConBinder
-> (TyConBinder -> IfL a) -> IfL a
-bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside
+bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
= bind_tv tv $ \tv' ->
- thing_inside (TvBndr tv' vis)
+ thing_inside (Bndr tv' vis)
diff --git a/compiler/iface/TcIface.hs-boot b/compiler/iface/TcIface.hs-boot
index 4a99114fc0..f137f13305 100644
--- a/compiler/iface/TcIface.hs-boot
+++ b/compiler/iface/TcIface.hs-boot
@@ -1,5 +1,6 @@
module TcIface where
+import GhcPrelude
import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule,
IfaceAnnotation, IfaceCompleteMatch )
import TyCoRep ( TyThing )
@@ -7,13 +8,11 @@ import TcRnTypes ( IfL )
import InstEnv ( ClsInst )
import FamInstEnv ( FamInst )
import CoreSyn ( CoreRule )
-import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo, CompleteMatch )
-import Module ( Module )
+import HscTypes ( CompleteMatch )
import Annotations ( Annotation )
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
-tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs
index 6f2acba21d..653b7407da 100644
--- a/compiler/iface/ToIface.hs
+++ b/compiler/iface/ToIface.hs
@@ -8,7 +8,7 @@ module ToIface
, toIfaceIdBndr
, toIfaceBndr
, toIfaceForAllBndr
- , toIfaceTyVarBinders
+ , toIfaceTyCoVarBinders
, toIfaceTyVar
-- * Types
, toIfaceType, toIfaceTypeX
@@ -22,7 +22,7 @@ module ToIface
, tidyToIfaceContext
, tidyToIfaceTcArgs
-- * Coercions
- , toIfaceCoercion
+ , toIfaceCoercion, toIfaceCoercionX
-- * Pattern synonyms
, patSynToIfaceDecl
-- * Expressions
@@ -44,6 +44,8 @@ module ToIface
#include "HsVersions.h"
+import GhcPrelude
+
import IfaceSyn
import DataCon
import Id
@@ -72,26 +74,39 @@ import Data.Maybe ( catMaybes )
----------------
toIfaceTvBndr :: TyVar -> IfaceTvBndr
-toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar)
- , toIfaceKind (tyVarKind tyvar)
- )
+toIfaceTvBndr = toIfaceTvBndrX emptyVarSet
-toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
-toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
+toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
+toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
+ , toIfaceTypeX fr (tyVarKind tyvar)
+ )
toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]
toIfaceTvBndrs = map toIfaceTvBndr
+toIfaceIdBndr :: Id -> IfaceIdBndr
+toIfaceIdBndr = toIfaceIdBndrX emptyVarSet
+
+toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
+toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar)
+ , toIfaceTypeX fr (varType covar)
+ )
+
toIfaceBndr :: Var -> IfaceBndr
toIfaceBndr var
| isId var = IfaceIdBndr (toIfaceIdBndr var)
| otherwise = IfaceTvBndr (toIfaceTvBndr var)
-toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis
-toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis
+toIfaceBndrX :: VarSet -> Var -> IfaceBndr
+toIfaceBndrX fr var
+ | isId var = IfaceIdBndr (toIfaceIdBndrX fr var)
+ | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var)
+
+toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis
+toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis
-toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis]
-toIfaceTyVarBinders = map toIfaceTyVarBinder
+toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis]
+toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder
{-
************************************************************************
@@ -116,9 +131,14 @@ toIfaceTypeX :: VarSet -> Type -> IfaceType
toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in IfaceType
| tv `elemVarSet` fr = IfaceFreeTyVar tv
| otherwise = IfaceTyVar (toIfaceTyVar tv)
-toIfaceTypeX fr (AppTy t1 t2) = IfaceAppTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
+toIfaceTypeX fr ty@(AppTy {}) =
+ -- Flatten as many argument AppTys as possible, then turn them into an
+ -- IfaceAppArgs list.
+ -- See Note [Suppressing invisible arguments] in IfaceType.
+ let (head, args) = splitAppTys ty
+ in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args)
toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n)
-toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b)
+toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
(toIfaceTypeX (fr `delVarSet` binderVar b) t)
toIfaceTypeX fr (FunTy t1 t2)
| isPredTy t1 = IfaceDFunTy (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
@@ -137,15 +157,11 @@ toIfaceTypeX fr (TyConApp tc tys)
, n_tys == 2*arity
= IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))
- -- type equalities: see Note [Equality predicates in IfaceType]
- | tyConName tc == eqTyConName
- = let info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon True)
- in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
-
| tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
- , [k1, k2, _t1, _t2] <- tys
- = let homogeneous = k1 `eqType` k2
- info = IfaceTyConInfo IsNotPromoted (IfaceEqualityTyCon homogeneous)
+ , (k1:k2:_) <- tys
+ = let info = IfaceTyConInfo IsNotPromoted sort
+ sort | k1 `eqType` k2 = IfaceEqualityTyCon
+ | otherwise = IfaceNormalTyCon
in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
-- other applications
@@ -161,8 +177,11 @@ toIfaceTyVar = occNameFS . getOccName
toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
-toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr
-toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis
+toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr
+toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet
+
+toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr
+toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
@@ -216,15 +235,23 @@ toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
toIfaceCoercionX fr co
= go co
where
- go (Refl r ty) = IfaceReflCo r (toIfaceType ty)
- go (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv)
+ go_mco MRefl = IfaceMRefl
+ go_mco (MCo co) = IfaceMCo $ go co
+
+ go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty)
+ go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)
+ go (CoVarCo cv)
+ -- See [TcTyVars in IfaceType] in IfaceType
+ | cv `elemVarSet` fr = IfaceFreeCoVar cv
+ | otherwise = IfaceCoVarCo (toIfaceCoVar cv)
+ go (HoleCo h) = IfaceHoleCo (coHoleCoVar h)
+
go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2)
go (SymCo co) = IfaceSymCo (go co)
go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2)
- go (NthCo d co) = IfaceNthCo d (go co)
+ go (NthCo _r d co) = IfaceNthCo d (go co)
go (LRCo lr co) = IfaceLRCo lr (go co)
go (InstCo co arg) = IfaceInstCo (go co) (go arg)
- go (CoherenceCo c1 c2) = IfaceCoherenceCo (go c1) (go c2)
go (KindCo c) = IfaceKindCo (go c)
go (SubCo co) = IfaceSubCo (go co)
go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs)
@@ -236,10 +263,9 @@ toIfaceCoercionX fr co
| tc `hasKey` funTyConKey
, [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co)
| otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)
- go (FunCo r co1 co2) = IfaceFunCo r (toIfaceCoercion co1)
- (toIfaceCoercion co2)
+ go (FunCo r co1 co2) = IfaceFunCo r (go co1) (go co2)
- go (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv)
+ go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv)
(toIfaceCoercionX fr' k)
(toIfaceCoercionX fr' co)
where
@@ -250,13 +276,18 @@ toIfaceCoercionX fr co
go_prov (PhantomProv co) = IfacePhantomProv (go co)
go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
go_prov (PluginProv str) = IfacePluginProv str
- go_prov (HoleProv h) = IfaceHoleProv (chUnique h)
-toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
+toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgs = toIfaceTcArgsX emptyVarSet
-toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs
--- See Note [Suppressing invisible arguments]
+toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs
+toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args
+
+toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs
+toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args
+
+toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs
+-- See Note [Suppressing invisible arguments] in IfaceType
-- We produce a result list of args describing visibility
-- The awkward case is
-- T :: forall k. * -> k
@@ -264,34 +295,43 @@ toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceTcArgs
-- T (forall j. blah) * blib
-- Is 'blib' visible? It depends on the visibility flag on j,
-- so we have to substitute for k. Annoying!
-toIfaceTcArgsX fr tc ty_args
- = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args
+toIfaceAppArgsX fr kind ty_args
+ = go (mkEmptyTCvSubst in_scope) kind ty_args
where
in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
- go _ _ [] = ITC_Nil
+ go _ _ [] = IA_Nil
go env ty ts
| Just ty' <- coreView ty
= go env ty' ts
- go env (ForAllTy (TvBndr tv vis) res) (t:ts)
- | isVisibleArgFlag vis = ITC_Vis t' ts'
- | otherwise = ITC_Invis t' ts'
+ go env (ForAllTy (Bndr tv vis) res) (t:ts)
+ | isVisibleArgFlag vis = IA_Vis t' ts'
+ | otherwise = IA_Invis t' ts'
where
t' = toIfaceTypeX fr t
- ts' = go (extendTvSubst env tv t) res ts
+ ts' = go (extendTCvSubst env tv t) res ts
go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps
- = ITC_Vis (toIfaceTypeX fr t) (go env res ts)
-
- go env (TyVarTy tv) ts
- | Just ki <- lookupTyVar env tv = go env ki ts
- go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )
- ITC_Vis (toIfaceTypeX fr t) (go env kind ts) -- Ill-kinded
+ = IA_Vis (toIfaceTypeX fr t) (go env res ts)
+
+ go env ty ts@(t1:ts1)
+ | not (isEmptyTCvSubst env)
+ = go (zapTCvSubst env) (substTy env ty) ts
+ -- See Note [Care with kind instantiation] in Type.hs
+
+ | otherwise
+ = -- There's a kind error in the type we are trying to print
+ -- e.g. kind = k, ty_args = [Int]
+ -- This is probably a compiler bug, so we print a trace and
+ -- carry on as if it were FunTy. Without the test for
+ -- isEmptyTCvSubst we'd get an infinite loop (Trac #15473)
+ WARN( True, ppr kind $$ ppr ty_args )
+ IA_Vis (toIfaceTypeX fr t1) (go env ty ts1)
tidyToIfaceType :: TidyEnv -> Type -> IfaceType
tidyToIfaceType env ty = toIfaceType (tidyType env ty)
-tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs
+tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
@@ -323,8 +363,8 @@ patSynToIfaceDecl ps
(_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
univ_bndrs = patSynUnivTyVarBinders ps
ex_bndrs = patSynExTyVarBinders ps
- (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs
- (env2, ex_bndrs') = tidyTyVarBinders env1 ex_bndrs
+ (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs
+ (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs
to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
{-
@@ -436,8 +476,15 @@ toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
-- No need to serialise the data constructor;
-- we can recover it from the type of the dfun
-toIfUnfolding _ _
- = Nothing
+toIfUnfolding _ (OtherCon {}) = Nothing
+ -- The binding site of an Id doesn't have OtherCon, except perhaps
+ -- where we have called zapUnfolding; and that evald'ness info is
+ -- not needed by importing modules
+
+toIfUnfolding _ BootUnfolding = Nothing
+ -- Can't happen; we only have BootUnfolding for imported binders
+
+toIfUnfolding _ NoUnfolding = Nothing
{-
************************************************************************
@@ -515,19 +562,22 @@ toIfaceApp (Var v) as
toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
-mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
+mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as
---------------------
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
- | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
- -- Foreign calls have special syntax
| isBootUnfolding (idUnfolding v)
- = IfaceApp (IfaceApp (IfaceExt noinlineIdName) (IfaceType (toIfaceType (idType v))))
+ = -- See Note [Inlining and hs-boot files]
+ IfaceApp (IfaceApp (IfaceExt noinlineIdName)
+ (IfaceType (toIfaceType (idType v))))
(IfaceExt name) -- don't use mkIfaceApps, or infinite loop
- -- See Note [Inlining and hs-boot files]
- | isExternalName name = IfaceExt name
- | otherwise = IfaceLcl (getOccFS name)
+
+ | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
+ -- Foreign calls have special syntax
+
+ | isExternalName name = IfaceExt name
+ | otherwise = IfaceLcl (getOccFS name)
where name = idName v
diff --git a/compiler/iface/ToIface.hs-boot b/compiler/iface/ToIface.hs-boot
index e2431b82dc..e5f57ff9a3 100644
--- a/compiler/iface/ToIface.hs-boot
+++ b/compiler/iface/ToIface.hs-boot
@@ -2,15 +2,15 @@ module ToIface where
import {-# SOURCE #-} TyCoRep
import {-# SOURCE #-} IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr
- , IfaceCoercion, IfaceTyLit, IfaceTcArgs )
-import Var ( TyVarBinder )
+ , IfaceCoercion, IfaceTyLit, IfaceAppArgs )
+import Var ( TyCoVarBinder )
import TyCon ( TyCon )
import VarSet( VarSet )
-- For TyCoRep
toIfaceTypeX :: VarSet -> Type -> IfaceType
toIfaceTyLit :: TyLit -> IfaceTyLit
-toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr
+toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr
toIfaceTyCon :: TyCon -> IfaceTyCon
-toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
-toIfaceCoercion :: Coercion -> IfaceCoercion
+toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
+toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
View Lorry Controller Status